Theory CZH_Sets_MIF
section‹Mutliway If›
theory CZH_Sets_MIF
imports Main
begin
text‹
The code that is presented in this section was originally written
by Manuel Eberl and appeared in a post on the mailing list of Isabelle:
\cite{eberl_syntax_2021}.
The code was ported with minor amendments by the author of this work.
›
abbreviation multi_If :: "bool ⇒ 'a ⇒ 'a ⇒ 'a"
where "multi_If ≡ If"
nonterminal if_clauses and if_clause
syntax
"_if_block" :: "if_clauses ⇒ 'a" ("(1if _)" [12] 10)
"_if_clause" :: "bool ⇒ 'a ⇒ if_clause" ("(2_ ⇒/ _)" 13)
"_if_final" :: "'a ⇒ if_clauses" ("otherwise ⇒ _")
"_if_cons" :: "[if_clause, if_clauses] ⇒ if_clauses" ("_ /| _" [13, 12] 12)
syntax (ASCII)
"_if_clause" :: "[pttrn, 'a] ⇒ if_clause" ("(2_ =>/ _)" 13)
translations
"_if_block (_if_cons (_if_clause b t) (_if_final e))"
⇌ "CONST multi_If b t e"
"_if_block (_if_cons b (_if_cons c cs))"
⇌ "_if_block (_if_cons b (_if_final (_if_block (_if_cons c cs))))"
"_if_block (_if_final e)" ⇀ "e"
text‹\newpage›
end
Theory CZH_Utilities
section‹Utilities›
theory CZH_Utilities
imports Main
keywords "lemmas_with" :: thy_decl
begin
text‹
Then command \<^text>‹lemmas_with› is a copy (with minor amendments to formatting)
of the command with the identical name that was introduced by Ondřej Kunčar in
\<^text>‹HOL-Types_To_Sets.Prerequisites›. A copy of the function was produced,
primarily, to avoid the unnecessary dependency of this work on the
axioms associated with the framework ‹Types-To-Sets›.
›
ML‹
val _ =
Outer_Syntax.local_theory'
\<^command_keyword>‹lemmas_with›
"note theorems with (the same) attributes"
(
Parse.attribs --| \<^keyword>‹:› --
Parse_Spec.name_facts --
Parse.for_fixes >>
(
fn (((attrs),facts), fixes) =>
#2 oo Specification.theorems_cmd Thm.theoremK
(map (apsnd (map (apsnd (fn xs => attrs@xs)))) facts) fixes
)
)
›
text‹\newpage›
end
Theory CZH_Introduction
chapter‹Introduction›
theory CZH_Introduction
imports ZFC_in_HOL.ZFC_Typeclasses
begin
section‹Background›
text‹
This article presents a foundational framework
that will be used for the formalization of
elements of the theory of 1-categories in the object logic
‹ZFC in HOL› (\cite{paulson_zermelo_2019}, also see
\cite{barkaoui_partizan_2006}) of the formal proof assistant
‹Isabelle› \cite{paulson_natural_1986} in future articles.
It is important to note that this chapter serves as
an introduction to the entire development and not merely
its foundational part.
There already exist several formalizations of the foundations of category
theory in Isabelle. In the context of the work presented here, the most relevant
formalizations (listed in the chronological order) are
\cite{okeefe_category_2005}, \cite{katovsky_category_2010} and
\cite{stark_category_2016}.
Arguably, the most well developed and maintained entry is
\cite{stark_category_2016}: it subsumes the majority of the content of
\cite{okeefe_category_2005} and \cite{katovsky_category_2010}.
From the perspective of the methodology that was chosen for the formalization,
this work differs significantly from the aforementioned previous work.
In particular, the categories are modelled as terms of the type \<^typ>‹V›
and no attempt is made to generalize the concept of a category to arbitrary
types. The inspiration for the chosen approach is drawn from
\cite{feferman_set-theoretical_1969},
\cite{sica_doing_2006} and \cite{shulman_set_2008}.
The primary references for this work are
‹Categories for the Working Mathematician› \cite{mac_lane_categories_2010}
by Saunders Mac Lane, ‹Category Theory in Context›
by Emily Riehl \cite{riehl_category_2016} and
‹Categories and Functors› by Bodo Pareigis \cite{bodo_categories_1970}.
The secondary sources of information include the textbooks
\cite{adamek_abstract_2006} and \cite{hungerford_algebra_2003},
as well as several online encyclopedias
(including \cite{noauthor_nlab_nodate},
\cite{noauthor_wikipedia_2001},
\cite{noauthor_proofwiki_nodate}
and \cite{noauthor_encyclopedia_nodate}).
Of course, inspiration was also drawn from the previous formalizations of
category theory in Isabelle.
It is likely that none of the content that is formalized in this work
is original in nature. However, explicit citations
are not provided for many results that were deemed to be trivial.
›
section‹Related and previous work›
text‹
To the best knowledge of the author, this work is the first attempt
to develop a formalization of elements of category theory in the
object logic ZFC in HOL by modelling categories as terms of the type \<^typ>‹V›.
However, it should be noted that the formalization of category theory in
\cite{katovsky_category_2010} largely rested
on the object logic HOL/ZF \cite{barkaoui_partizan_2006}, which is
equiconsistent with the ZFC in HOL \cite{paulson_zermelo_2019}.
Nonetheless, in \cite{katovsky_category_2010}, the objects and arrows
associated with categories were modelled as terms of arbitrary
types. The object logic HOL/ZF was used for the exposition of
the category ‹Set› of all sets and functions between them
and a variety of closely related concepts.
In this sense, the methodology employed in
\cite{katovsky_category_2010} could be seen as a combination of the
methodology employed in this work and the methodology followed in
\cite{okeefe_category_2005} and \cite{stark_category_2016}.
Furthermore, in \cite{chen_hotg_2021},
the authors have experimented with the formalization of category
theory in Higher-Order Tarski-Grothendieck (HOTG)
theory \cite{brown_higher-order_2019} using a methodology that
shares many similarities with the approach that was chosen in this study.
The formalizations of various elements of category theory
in other proof assistants are abundant.
While a survey of such formalizations is outside of the scope of
this work, it is important to note that there exist at least two examples
of the formalization of elements of category theory in a set-theoretic setting
similar to the one that is used in this work.
More specifically, elements of category theory were formalized in
the Tarski-Grothendieck Set Theory in the Mizar proof assistant
\cite{noauthor_association_nodate} (and
published in the associated electronic journal
\cite{grabowski_preface_2014})
and the proof assistant Metamath
\cite{megill_metamath_2019}.
The following references contain some of the
relevant articles in \cite{grabowski_preface_2014}, but the list may not be
exhaustive:
\cite{bylinski_introduction_1990, bylinski_subcategories_1990,
bylinski_opposite_1991, trybulec_natural_1991,
bylinski_category_1991, muzalewski_categories_1991,
trybulec_isomorphisms_1991, muzalewski_category_1991,
muzalewski_category_1991-1, bancerek_comma_1991,
bylinski_products_1991, trybulec_isomorphisms_1992,
bylinski_cartesian_1992, bancerek_categorial_1996,
trybulec_categories_1996, bancerek_indexed_1996,
trybulec_functors_1996, nieszczerzewski_category_1997,
kornilowicz_categories_1997,
kornilowicz_composition_1998,
bancerek_concrete_2001,
kornilowicz_products_2012,
riccardi_object-free_2013,
golinski_coproducts_2013,
riccardi_categorical_2015,
riccardi_exponential_2015}.
›
end
Theory CZH_Sets_Introduction
chapter‹Set Theory for Category Theory›
section‹Introduction›
theory CZH_Sets_Introduction
imports
CZH_Introduction
CZH_Sets_MIF
CZH_Utilities
Intro_Dest_Elim.IHOL_IDE
Conditional_Simplification.IHOL_CS
ZFC_in_HOL.Cantor_NF
"HOL-Eisbach.Eisbach"
begin
subsection‹Background›
text‹
This chapter presents a formalization of the elements of set theory in
the object logic ‹ZFC in HOL› (\cite{paulson_zermelo_2019}, also see
\cite{barkaoui_partizan_2006})
of the formal proof assistant Isabelle \cite{paulson_natural_1986}.
The emphasis of this work is on the improvement of the convenience of the
formalization of abstract mathematics internalized in the type \<^typ>‹V›.
›
subsection‹References, related and previous work›
text‹
The results that are presented in this chapter cannot be traced to a single
source of information. Nonetheless, the results are not original.
A significant number of these results was carried over (with amendments)
from the main library of Isabelle/HOL \cite{noauthor_isabellehol_2020}.
Other results were inspired by elements of the content of the books
‹Introduction to Axiomatic Set Theory› by G. Takeuti
and W. M. Zaring \cite{takeuti_introduction_1971}, ‹Theory of Sets›
by N. Bourbaki \cite{bourbaki_elements_nodate} and ‹Algebra› by
T. W. Hungerford \cite{hungerford_algebra_2003}.
Furthermore, several online encyclopedias and forums
(including Wikipedia \cite{noauthor_wikipedia_2001},
ProofWiki \cite{noauthor_proofwiki_nodate},
Encyclopedia of Mathematics \cite{noauthor_encyclopedia_nodate},
nLab \cite{noauthor_nlab_nodate} and Mathematics Stack Exchange)
were used consistently throughout the development of this chapter.
Inspiration for the work presented in this chapter has also been drawn
from a similar ongoing project
in the formalization of mathematics in the system
HOTG (Higher Order Tarski-Grothendieck)
\cite{brown_higher-order_2019, chen_hotg_2021}.
It should also be mentioned that the Isabelle/HOL and the Isabelle/ML code
from the main distribution of Isabelle2020 and certain posts on the
mailing list of Isabelle were frequently reused
(with amendments) during the development of this chapter. Some of the
specific examples of such reuse are
\begin{itemize}
\item The adoption of the implementation of
the command @{command lemmas_with} that is available as part of
the framework Types-To-Sets in the main distribution of Isabelle2020.
\item The notation for the ``multiway-if'' was written
by Manuel Eberl and appeared in a post on the mailing list of Isabelle:
\cite{eberl_syntax_2021}.
\end{itemize}
›
hide_const (open) list.set Sum subset
lemmas ord_of_nat_zero = ord_of_nat.simps(1)
subsection‹Notation›
abbreviation (input) qm (‹(_ ? _ : _)› [0, 0, 10] 10)
where "C ? A : B ≡ if C then A else B"
abbreviation (input) if2 where "if2 a b ≡ (λi. (i = 0 ? a : b))"
subsection‹Further foundational results›
lemma theD:
assumes "∃!x. P x" and "x = (THE x. P x)"
shows "P x" and "P y ⟹ x = y"
using assms by (metis theI)+
lemmas [intro] = bij_betw_imageI
lemma bij_betwE[elim]:
assumes "bij_betw f A B" and "⟦ inj_on f A; f ` A = B ⟧ ⟹ P"
shows P
using assms unfolding bij_betw_def by auto
lemma bij_betwD[dest]:
assumes "bij_betw f A B"
shows "inj_on f A" and "f ` A = B"
using assms by auto
text‹\newpage›
end
Theory CZH_Sets_Sets
section‹Further set algebra and other miscellaneous results›
theory CZH_Sets_Sets
imports CZH_Sets_Introduction
begin
subsection‹Background›
text‹
This section presents further set algebra and various elementary properties
of sets.
Many of the results that are presented in this section
were carried over (with amendments) from the theories \<^text>‹Set›
and \<^text>‹Complete_Lattices› in the main library.
›
declare elts_sup_iff[simp del]
subsection‹Further notation›
subsubsection‹Set membership›
abbreviation vmember :: "V ⇒ V ⇒ bool" ("(_/ ∈⇩∘ _)" [51, 51] 50)
where "vmember x A ≡ (x ∈ elts A)"
notation vmember ("'(∈⇩∘')")
and vmember ("(_/ ∈⇩∘ _)" [51, 51] 50)
abbreviation not_vmember :: "V ⇒ V ⇒ bool" ("(_/ ∉⇩∘ _)" [51, 51] 50)
where "not_vmember x A ≡ (x ∉ elts A)"
notation
not_vmember ("'(∉⇩∘')") and
not_vmember ("(_/ ∉⇩∘ _)" [51, 51] 50)
subsubsection‹Subsets›
abbreviation vsubset :: "V ⇒ V ⇒ bool"
where "vsubset ≡ less"
abbreviation vsubset_eq :: "V ⇒ V ⇒ bool"
where "vsubset_eq ≡ less_eq"
notation vsubset ("'(⊂⇩∘')")
and vsubset ("(_/ ⊂⇩∘ _)" [51, 51] 50)
and vsubset_eq ("'(⊆⇩∘')")
and vsubset_eq ("(_/ ⊆⇩∘ _)" [51, 51] 50)
subsubsection‹Ball›
syntax
"_VBall" :: "pttrn ⇒ V ⇒ bool ⇒ bool" ("(3∀(_/∈⇩∘_)./ _)" [0, 0, 10] 10)
"_VBex" :: "pttrn ⇒ V ⇒ bool ⇒ bool" ("(3∃(_/∈⇩∘_)./ _)" [0, 0, 10] 10)
"_VBex1" :: "pttrn ⇒ V ⇒ bool ⇒ bool" ("(3∃!(_/∈⇩∘_)./ _)" [0, 0, 10] 10)
translations
"∀x∈⇩∘A. P" ⇌ "CONST Ball (CONST elts A) (λx. P)"
"∃x∈⇩∘A. P" ⇌ "CONST Bex (CONST elts A) (λx. P)"
"∃!x∈⇩∘A. P" ⇀ "∃!x. x ∈⇩∘ A ∧ P"
subsubsection‹‹VLambda››
text‹The following notation was adapted from \cite{paulson_hereditarily_2013}.›
syntax "_vlam" :: "[pttrn, V, V] ⇒ V" (‹(3λ_∈⇩∘_./ _)› 10)
translations "λx∈⇩∘A. f" ⇌ "CONST VLambda A (λx. f)"
subsubsection‹Intersection and union›
abbreviation vintersection :: "V ⇒ V ⇒ V" (infixl "∩⇩∘" 70)
where "(∩⇩∘) ≡ (⊓)"
notation vintersection (infixl "∩⇩∘" 70)
abbreviation vunion :: "V ⇒ V ⇒ V" (infixl "∪⇩∘" 65)
where "vunion ≡ sup"
notation vunion (infixl "∪⇩∘" 65)
abbreviation VInter :: "V ⇒ V" (‹⋂⇩∘›)
where "⋂⇩∘ A ≡ ⨅ (elts A)"
notation VInter (‹⋂⇩∘›)
abbreviation VUnion :: "V ⇒ V" (‹⋃⇩∘›)
where "⋃⇩∘A ≡ ⨆ (elts A)"
notation VUnion (‹⋃⇩∘›)
subsubsection‹Miscellaneous›
notation app (‹_⦇_⦈› [999, 50] 999)
notation vtimes (infixr "×⇩∘" 80)
subsection‹Elementary results.›
lemma vempty_nin[simp]: "a ∉⇩∘ 0" by simp
lemma vemptyE:
assumes "A ≠ 0"
obtains x where "x ∈⇩∘ A"
using assms trad_foundation by auto
lemma in_set_CollectI:
assumes "P x" and "small {x. P x}"
shows "x ∈⇩∘ set {x. P x}"
using assms by simp
lemma small_setcompr2:
assumes "small {f x y | x y. P x y}" and "a ∈⇩∘ set {f x y | x y. P x y}"
obtains x' y' where "a = f x' y'" and "P x' y'"
using assms by auto
lemma in_small_setI:
assumes "small A" and "x ∈ A"
shows "x ∈⇩∘ set A"
using assms by simp
lemma in_small_setD:
assumes "x ∈⇩∘ set A" and "small A"
shows "x ∈ A"
using assms by simp
lemma in_small_setE:
assumes "a ∈⇩∘ set A" and "small A"
obtains "a ∈ A"
using assms by auto
lemma small_set_vsubset:
assumes "small A" and "A ⊆ elts B"
shows "set A ⊆⇩∘ B"
using assms by auto
lemma some_in_set_if_set_neq_vempty[simp]:
assumes "A ≠ 0"
shows "(SOME x. x ∈⇩∘ A) ∈⇩∘ A"
by (meson assms someI_ex vemptyE)
lemma small_vsubset_set[intro, simp]:
assumes "small B" and "A ⊆ B"
shows "set A ⊆⇩∘ set B"
using assms by (auto simp: subset_iff_less_eq_V)
lemma vset_neq_1:
assumes "b ∉⇩∘ A" and "a ∈⇩∘ A"
shows "b ≠ a"
using assms by auto
lemma vset_neq_2:
assumes "b ∈⇩∘ A" and "a ∉⇩∘ A"
shows "b ≠ a"
using assms by auto
lemma nin_vinsertI:
assumes "a ≠ b" and "a ∉⇩∘ A"
shows "a ∉⇩∘ vinsert b A"
using assms by clarsimp
lemma vsubset_if_subset:
assumes "elts A ⊆ elts B"
shows "A ⊆⇩∘ B"
using assms by auto
lemma small_set_comprehension[simp]: "small {A i | i. i ∈⇩∘ I}"
proof(rule smaller_than_small)
show "small (A ` elts I)" by auto
qed auto
subsection‹‹VBall››
lemma vball_cong:
assumes "A = B" and "⋀x. x ∈⇩∘ B ⟹ P x ⟷ Q x"
shows "(∀x∈⇩∘A. P x) ⟷ (∀x∈⇩∘B. Q x)"
by (simp add: assms)
lemma vball_cong_simp[cong]:
assumes "A = B" and "⋀x. x ∈⇩∘ B =simp=> P x ⟷ Q x "
shows "(∀x∈⇩∘A. P x) ⟷ (∀x∈⇩∘B. Q x)"
using assms by (simp add: simp_implies_def)
subsection‹‹VBex››
lemma vbex_cong:
assumes "A = B" and "⋀x. x ∈⇩∘ B ⟹ P x ⟷ Q x"
shows "(∃x∈⇩∘A. P x) ⟷ (∃x∈⇩∘B. Q x)"
using assms by (simp cong: conj_cong)
lemma vbex_cong_simp[cong]:
assumes "A = B" and "⋀x. x ∈⇩∘ B =simp=> P x ⟷ Q x "
shows "(∃x∈⇩∘A. P x) ⟷ (∃x∈⇩∘B. Q x)"
using assms by (simp add: simp_implies_def)
subsection‹Subset›
text‹Rules.›
lemma vsubset_antisym:
assumes "A ⊆⇩∘ B" and "B ⊆⇩∘ A"
shows "A = B"
using assms by simp
lemma vsubsetI:
assumes "⋀x. x ∈⇩∘ A ⟹ x ∈⇩∘ B"
shows "A ⊆⇩∘ B"
using assms by auto
lemma vpsubsetI:
assumes "A ⊆⇩∘ B" and "x ∉⇩∘ A" and "x ∈⇩∘ B"
shows "A ⊂⇩∘ B"
using assms unfolding less_V_def by auto
lemma vsubsetD:
assumes "A ⊆⇩∘ B"
shows "⋀x. x ∈⇩∘ A ⟹ x ∈⇩∘ B"
using assms by auto
lemma vsubsetE:
assumes "A ⊆⇩∘ B" and "(⋀x. x ∈⇩∘ A ⟹ x ∈⇩∘ B) ⟹ P"
shows P
using assms by auto
lemma vpsubsetE:
assumes "A ⊂⇩∘ B"
obtains x where "A ⊆⇩∘ B" and "x ∉⇩∘ A" and "x ∈⇩∘ B"
using assms unfolding less_V_def by (meson V_equalityI vsubsetE)
lemma vsubset_iff: "A ⊆⇩∘ B ⟷ (∀t. t ∈⇩∘ A ⟶ t ∈⇩∘ B)" by blast
text‹Elementary properties.›
lemma vsubset_eq: "A ⊆⇩∘ B ⟷ (∀x∈⇩∘A. x ∈⇩∘ B)" by auto
lemma vsubset_transitive[intro]:
assumes "A ⊆⇩∘ B" and "B ⊆⇩∘ C"
shows "A ⊆⇩∘ C"
using assms by simp
lemma vsubset_reflexive: "A ⊆⇩∘ A" by simp
text‹Set operations.›
lemma vsubset_vempty: "0 ⊆⇩∘ A" by simp
lemma vsubset_vsingleton_left: "set {a} ⊆⇩∘ A ⟷ a ∈⇩∘ A" by auto
lemmas vsubset_vsingleton_leftD[dest] = vsubset_vsingleton_left[THEN iffD1]
and vsubset_vsingleton_leftI[intro] = vsubset_vsingleton_left[THEN iffD2]
lemma vsubset_vsingleton_right: "A ⊆⇩∘ set {a} ⟷ A = set {a} ∨ A = 0"
by (auto intro!: vsubset_antisym)
lemmas vsubset_vsingleton_rightD[dest] = vsubset_vsingleton_right[THEN iffD1]
and vsubset_vsingleton_rightI[intro] = vsubset_vsingleton_right[THEN iffD2]
lemma vsubset_vdoubleton_leftD[dest]:
assumes "set {a, b} ⊆⇩∘ A"
shows "a ∈⇩∘ A" and "b ∈⇩∘ A"
using assms by auto
lemma vsubset_vdoubleton_leftI[intro]:
assumes "a ∈⇩∘ A" and "b ∈⇩∘ A"
shows "set {a, b} ⊆⇩∘ A"
using assms by auto
lemma vsubset_vinsert_leftD[dest]:
assumes "vinsert a A ⊆⇩∘ B"
shows "A ⊆⇩∘ B"
using assms by auto
lemma vsubset_vinsert_leftI[intro]:
assumes "A ⊆⇩∘ B" and "a ∈⇩∘ B"
shows "vinsert a A ⊆⇩∘ B"
using assms by auto
lemma vsubset_vinsert_vinsertI[intro]:
assumes "A ⊆⇩∘ vinsert b B"
shows "vinsert b A ⊆⇩∘ vinsert b B"
using assms by auto
lemma vsubset_vinsert_rightI[intro]:
assumes "A ⊆⇩∘ B"
shows "A ⊆⇩∘ vinsert b B"
using assms by auto
lemmas vsubset_VPow = VPow_le_VPow_iff
lemmas vsubset_VPowD = vsubset_VPow[THEN iffD1]
and vsubset_VPowI = vsubset_VPow[THEN iffD2]
text‹Special properties.›
lemma vsubset_contraD:
assumes "A ⊆⇩∘ B" and "c ∉⇩∘ B"
shows "c ∉⇩∘ A"
using assms by auto
subsection‹Equality›
text‹Rules.›
lemma vequalityD1:
assumes "A = B"
shows "A ⊆⇩∘ B"
using assms by simp
lemma vequalityD2:
assumes "A = B"
shows "B ⊆⇩∘ A"
using assms by simp
lemma vequalityE:
assumes "A = B" and "⟦ A ⊆⇩∘ B; B ⊆⇩∘ A ⟧ ⟹ P"
shows P
using assms by simp
lemma vequalityCE[elim]:
assumes "A = B" and "⟦ c ∈⇩∘ A; c ∈⇩∘ B ⟧ ⟹ P" and "⟦ c ∉⇩∘ A; c ∉⇩∘ B ⟧ ⟹ P"
shows P
using assms by auto
subsection‹Binary intersection›
lemma vintersection_def: "A ∩⇩∘ B = set {x. x ∈⇩∘ A ∧ x ∈⇩∘ B}"
by (metis Int_def inf_V_def)
lemma small_vintersection_set[simp]: "small {x. x ∈⇩∘ A ∧ x ∈⇩∘ B}"
by (rule down[of _ A]) auto
text‹Rules.›
lemma vintersection_iff[simp]: "x ∈⇩∘ A ∩⇩∘ B ⟷ x ∈⇩∘ A ∧ x ∈⇩∘ B"
unfolding vintersection_def by simp
lemma vintersectionI[intro!]:
assumes "x ∈⇩∘ A" and "x ∈⇩∘ B"
shows "x ∈⇩∘ A ∩⇩∘ B"
using assms by simp
lemma vintersectionD1[dest]:
assumes "x ∈⇩∘ A ∩⇩∘ B"
shows "x ∈⇩∘ A"
using assms by simp
lemma vintersectionD2[dest]:
assumes "x ∈⇩∘ A ∩⇩∘ B"
shows "x ∈⇩∘ B"
using assms by simp
lemma vintersectionE[elim!]:
assumes "x ∈⇩∘ A ∩⇩∘ B" and "x ∈⇩∘ A ⟹ x ∈⇩∘ B ⟹ P"
shows P
using assms by simp
text‹Elementary properties.›
lemma vintersection_intersection: "A ∩⇩∘ B = set (elts A ∩ elts B)"
unfolding inf_V_def by simp
lemma vintersection_assoc: "A ∩⇩∘ (B ∩⇩∘ C) = (A ∩⇩∘ B) ∩⇩∘ C" by auto
lemma vintersection_commutativity: "A ∩⇩∘ B = B ∩⇩∘ A" by auto
text‹Previous set operations.›
lemma vsubset_vintersection_right: "A ⊆⇩∘ (B ∩⇩∘ C) = (A ⊆⇩∘ B ∧ A ⊆⇩∘ C)"
by clarsimp
lemma vsubset_vintersection_rightD[dest]:
assumes "A ⊆⇩∘ (B ∩⇩∘ C)"
shows "A ⊆⇩∘ B" and "A ⊆⇩∘ C"
using assms by auto
lemma vsubset_vintersection_rightI[intro]:
assumes "A ⊆⇩∘ B" and "A ⊆⇩∘ C"
shows "A ⊆⇩∘ (B ∩⇩∘ C)"
using assms by auto
text‹Set operations.›
lemma vintersection_vempty: "0 ⊆⇩∘ A" by simp
lemma vintersection_vsingleton: "a ∈⇩∘ set {a}" by simp
lemma vintersection_vdoubleton: "a ∈⇩∘ set {a, b}" and "b ∈⇩∘ set {a, b}"
by simp_all
lemma vintersection_VPow[simp]: "VPow (A ∩⇩∘ B) = VPow A ∩⇩∘ VPow B" by auto
text‹Special properties.›
lemma vintersection_function_mono:
assumes "mono f"
shows "f (A ∩⇩∘ B) ⊆⇩∘ f A ∩⇩∘ f B"
using assms by (fact mono_inf)
subsection‹Binary union›
lemma small_vunion_set: "small {x. x ∈⇩∘ A ∨ x ∈⇩∘ B}"
by (rule down[of _ ‹A ∪⇩∘ B›]) (auto simp: elts_sup_iff)
text‹Rules.›
lemma vunion_def: "A ∪⇩∘ B = set {x. x ∈⇩∘ A ∨ x ∈⇩∘ B}"
unfolding Un_def sup_V_def by simp
lemma vunion_iff[simp]: "x ∈⇩∘ A ∪⇩∘ B ⟷ x ∈⇩∘ A ∨ x ∈⇩∘ B"
by (simp add: elts_sup_iff)
lemma vunionI1:
assumes "a ∈⇩∘ A"
shows "a ∈⇩∘ A ∪⇩∘ B"
using assms by simp
lemma vunionI2:
assumes "a ∈⇩∘ B"
shows "a ∈⇩∘ A ∪⇩∘ B"
using assms by simp
lemma vunionCI[intro!]:
assumes "x ∉⇩∘ B ⟹ x ∈⇩∘ A"
shows "x ∈⇩∘ A ∪⇩∘ B"
using assms by clarsimp
lemma vunionE[elim!]:
assumes "x ∈⇩∘ A ∪⇩∘ B" and "x ∈⇩∘ A ⟹ P" and "x ∈⇩∘ B ⟹ P"
shows P
using assms by auto
text‹Elementary properties.›
lemma vunion_union: "A ∪⇩∘ B = set (elts A ∪ elts B)" by auto
lemma vunion_assoc: "A ∪⇩∘ (B ∪⇩∘ C) = (A ∪⇩∘ B) ∪⇩∘ C" by auto
lemma vunion_comm: "A ∪⇩∘ B = B ∪⇩∘ A" by auto
text‹Previous set operations.›
lemma vsubset_vunion_left: "(A ∪⇩∘ B) ⊆⇩∘ C ⟷ (A ⊆⇩∘ C ∧ B ⊆⇩∘ C)" by simp
lemma vsubset_vunion_leftD[dest]:
assumes "(A ∪⇩∘ B) ⊆⇩∘ C"
shows "A ⊆⇩∘ C" and "B ⊆⇩∘ C"
using assms by auto
lemma vsubset_vunion_leftI[intro]:
assumes "A ⊆⇩∘ C" and "B ⊆⇩∘ C"
shows "(A ∪⇩∘ B) ⊆⇩∘ C"
using assms by auto
lemma vintersection_vunion_left: "(A ∪⇩∘ B) ∩⇩∘ C = (A ∩⇩∘ C) ∪⇩∘ (B ∩⇩∘ C)"
by auto
lemma vintersection_vunion_right: "A ∩⇩∘ (B ∪⇩∘ C) = (A ∩⇩∘ B) ∪⇩∘ (A ∩⇩∘ C)"
by auto
text‹Set operations.›
lemmas vunion_vempty_left = sup_V_0_left
and vunion_vempty_right = sup_V_0_right
lemma vunion_vsingleton[simp]: "set {a} ∪⇩∘ A = vinsert a A" by auto
lemma vunion_vdoubleton[simp]: "set {a, b} ∪⇩∘ A = vinsert a (vinsert b A)"
by auto
lemma vunion_vinsert_commutativity_left:
"(vinsert a A) ∪⇩∘ B = A ∪⇩∘ (vinsert a B)"
by auto
lemma vunion_vinsert_commutativity_right:
"A ∪⇩∘ (vinsert a B) = (vinsert a A) ∪⇩∘ B"
by auto
lemma vinsert_def: "vinsert y B = set {x. x = y} ∪⇩∘ B" by auto
lemma vunion_vinsert_left: "(vinsert a A) ∪⇩∘ B = vinsert a (A ∪⇩∘ B)" by auto
lemma vunion_vinsert_right: "A ∪⇩∘ (vinsert a B) = vinsert a (A ∪⇩∘ B)" by auto
text‹Special properties.›
lemma vunion_fun_mono:
assumes "mono f"
shows "f A ∪⇩∘ f B ⊆⇩∘ f (A ∪⇩∘ B)"
using assms by (fact mono_sup)
subsection‹Set difference›
definition vdiff :: "V ⇒ V ⇒ V" (infixl ‹-⇩∘› 65)
where "A -⇩∘ B = set {x. x ∈⇩∘ A ∧ x ∉⇩∘ B}"
notation vdiff (infixl "-⇩∘" 65)
lemma small_set_vdiff[simp]: "small {x. x ∈⇩∘ A ∧ x ∉⇩∘ B}"
by (rule down[of _ A]) simp
text‹Rules.›
lemma vdiff_iff[simp]: "x ∈⇩∘ A -⇩∘ B ⟷ x ∈⇩∘ A ∧ x ∉⇩∘ B"
unfolding vdiff_def by simp
lemma vdiffI[intro!]:
assumes "x ∈⇩∘ A" and "x ∉⇩∘ B"
shows "x ∈⇩∘ A -⇩∘ B"
using assms by simp
lemma vdiffD1:
assumes "x ∈⇩∘ A -⇩∘ B"
shows "x ∈⇩∘ A"
using assms by simp
lemma vdiffD2:
assumes "x ∈⇩∘ A -⇩∘ B" and "x ∈⇩∘ B"
shows P
using assms by simp
lemma vdiffE[elim!]:
assumes "x ∈⇩∘ A -⇩∘ B" and "⟦ x ∈⇩∘ A; x ∉⇩∘ B ⟧ ⟹ P"
shows P
using assms by simp
text‹Previous set operations.›
lemma vsubset_vdiff:
assumes "A ⊆⇩∘ B -⇩∘ C"
shows "A ⊆⇩∘ B"
using assms by auto
lemma vinsert_vdiff_nin[simp]:
assumes "a ∉⇩∘ B"
shows "vinsert a (A -⇩∘ B) = vinsert a A -⇩∘ B"
using assms by auto
text‹Set operations.›
lemma vdiff_vempty_left[simp]: "0 -⇩∘ A = 0" by auto
lemma vdiff_vempty_right[simp]: "A -⇩∘ 0 = A" by auto
lemma vdiff_vsingleton_vinsert[simp]: "set {a} -⇩∘ vinsert a A = 0" by auto
lemma vdiff_vsingleton_in[simp]:
assumes "a ∈⇩∘ A"
shows "set {a} -⇩∘ A = 0"
using assms by auto
lemma vdiff_vsingleton_nin[simp]:
assumes "a ∉⇩∘ A"
shows "set {a} -⇩∘ A = set {a}"
using assms by auto
lemma vdiff_vinsert_vsingleton[simp]: "vinsert a A -⇩∘ set {a} = A -⇩∘ set {a}"
by auto
lemma vdiff_vsingleton[simp]:
assumes "a ∉⇩∘ A"
shows "A -⇩∘ set {a} = A"
using assms by auto
lemma vdiff_vsubset:
assumes "A ⊆⇩∘ B" and "D ⊆⇩∘ C"
shows "A -⇩∘ C ⊆⇩∘ B -⇩∘ D"
using assms by auto
lemma vdiff_vinsert_left_in[simp]:
assumes "a ∈⇩∘ B"
shows "(vinsert a A) -⇩∘ B = A -⇩∘ B"
using assms by auto
lemma vdiff_vinsert_left_nin:
assumes "a ∉⇩∘ B"
shows "(vinsert a A) -⇩∘ B = vinsert a (A -⇩∘ B)"
using assms by auto
lemma vdiff_vinsert_right_in: "A -⇩∘ (vinsert a B) = A -⇩∘ B -⇩∘ set {a}" by auto
lemma vdiff_vinsert_right_nin[simp]:
assumes "a ∉⇩∘ A"
shows "A -⇩∘ (vinsert a B) = A -⇩∘ B"
using assms by auto
lemma vdiff_vintersection_left: "(A ∩⇩∘ B) -⇩∘ C = (A -⇩∘ C) ∩⇩∘ (B -⇩∘ C)" by auto
lemma vdiff_vunion_left: "(A ∪⇩∘ B) -⇩∘ C = (A -⇩∘ C) ∪⇩∘ (B -⇩∘ C)" by auto
text‹Special properties.›
lemma complement_vsubset: "I -⇩∘ J ⊆⇩∘ I" by auto
lemma vintersection_complement: "(I -⇩∘ J) ∩⇩∘ J = 0" by auto
lemma vunion_complement:
assumes "J ⊆⇩∘ I"
shows "I -⇩∘ J ∪⇩∘ J = I"
using assms by auto
subsection‹Augmenting a set with an element›
lemma vinsert_compr: "vinsert y A = set {x. x = y ∨ x ∈⇩∘ A}"
unfolding vunion_def vinsert_def by simp_all
text‹Rules.›
lemma vinsert_iff[simp]: "x ∈⇩∘ vinsert y A ⟷ x = y ∨ x ∈⇩∘ A" by simp
lemma vinsertI1: "x ∈⇩∘ vinsert x A" by simp
lemma vinsertI2:
assumes "x ∈⇩∘ A"
shows "x ∈⇩∘ vinsert y A"
using assms by simp
lemma vinsertE1[elim!]:
assumes "x ∈⇩∘ vinsert y A" and "x = y ⟹ P" and "x ∈⇩∘ A ⟹ P"
shows P
using assms unfolding vinsert_def by auto
lemma vinsertCI[intro!]:
assumes "x ∉⇩∘ A ⟹ x = y"
shows "x ∈⇩∘ vinsert y A"
using assms by clarsimp
text‹Elementary properties.›
lemma vinsert_insert: "vinsert a A = set (insert a (elts A))" by auto
lemma vinsert_commutativity: "vinsert a (vinsert b C) = vinsert b (vinsert a C)"
by auto
lemma vinsert_ident:
assumes "x ∉⇩∘ A" and "x ∉⇩∘ B"
shows "vinsert x A = vinsert x B ⟷ A = B"
using assms by force
lemmas vinsert_identD[dest] = vinsert_ident[THEN iffD1, rotated 2]
and vinsert_identI[intro] = vinsert_ident[THEN iffD2]
text‹Set operations.›
lemma vinsert_vempty: "vinsert a 0 = set {a}" by auto
lemma vinsert_vsingleton: "vinsert a (set {b}) = set {a, b}" by auto
lemma vinsert_vdoubleton: "vinsert a (set {b, c}) = set {a, b, c}" by auto
lemma vinsert_vinsert: "vinsert a (vinsert b C) = set {a, b} ∪⇩∘ C" by auto
lemma vinsert_vunion_left: "vinsert a (A ∪⇩∘ B) = vinsert a A ∪⇩∘ B" by auto
lemma vinsert_vunion_right: "vinsert a (A ∪⇩∘ B) = A ∪⇩∘ vinsert a B" by auto
lemma vinsert_vintersection: "vinsert a (A ∩⇩∘ B) = vinsert a A ∩⇩∘ vinsert a B"
by auto
text‹Special properties.›
lemma vinsert_set_insert_empty_anyI:
assumes "P (vinsert a 0)"
shows "P (set (insert a {}))"
using assms by (simp add: vinsert_def)
lemma vinsert_set_insert_anyI:
assumes "small B" and "P (vinsert a (set (insert b B)))"
shows "P (set (insert a (insert b B)))"
using assms by (simp add: ZFC_in_HOL.vinsert_def)
lemma vinsert_set_insert_eq:
assumes "small B"
shows "set (insert a (insert b B)) = vinsert a (set (insert b B))"
using assms by (simp add: ZFC_in_HOL.vinsert_def)
lemma vsubset_vinsert:
"A ⊆⇩∘ vinsert x B ⟷ (if x ∈⇩∘ A then A -⇩∘ set {x} ⊆⇩∘ B else A ⊆⇩∘ B)"
by auto
lemma vinsert_obtain_ne:
assumes "A ≠ 0"
obtains a A' where "A = vinsert a A'" and "a ∉⇩∘ A'"
proof-
from assms mem_not_refl obtain a where "a ∈⇩∘ A"
by (auto intro!: vsubset_antisym)
with ‹a ∈⇩∘ A› have "A = vinsert a (A -⇩∘ set {a})" by auto
then show ?thesis using that by auto
qed
subsection‹Power set›
text‹Rules.›
lemma VPowI:
assumes "A ⊆⇩∘ B"
shows "A ∈⇩∘ VPow B"
using assms by simp
lemma VPowD:
assumes "A ∈⇩∘ VPow B"
shows "A ⊆⇩∘ B"
using assms by (simp add: Pow_def)
lemma VPowE[elim]:
assumes "A ∈⇩∘ VPow B" and "A ⊆⇩∘ B ⟹ P"
shows P
using assms by auto
text‹Elementary properties.›
lemma VPow_bottom: "0 ∈⇩∘ VPow B" by simp
lemma VPow_top: "A ∈⇩∘ VPow A" by simp
text‹Set operations.›
lemma VPow_vempty[simp]: "VPow 0 = set {0}" by auto
lemma VPow_vsingleton[simp]: "VPow (set {a}) = set {0, set {a}}"
by (rule vsubset_antisym; rule vsubsetI) auto
lemma VPow_not_vempty: "VPow A ≠ 0" by auto
lemma VPow_mono:
assumes "A ⊆⇩∘ B"
shows "VPow A ⊆⇩∘ VPow B"
using assms by simp
lemma VPow_vunion_subset: "VPow A ∪⇩∘ VPow B ⊆⇩∘ VPow (A ∪⇩∘ B)" by simp
subsection‹Singletons, using insert›
text‹Rules.›
lemma vsingletonI[intro!]: "x ∈⇩∘ set {x}" by auto
lemma vsingletonD[dest!]:
assumes "y ∈⇩∘ set {x}"
shows "y = x"
using assms by auto
lemma vsingleton_iff: "y ∈⇩∘ set {x} ⟷ y = x" by simp
text‹Previous set operations.›
lemma VPow_vdoubleton[simp]:
"VPow (set {a, b}) = set {0, set {a}, set {b}, set {a, b}}"
by (intro vsubset_antisym vsubsetI)
(auto intro!: vsubset_antisym simp: vinsert_set_insert_eq)
lemma vsubset_vinsertI:
assumes "A -⇩∘ set {x} ⊆⇩∘ B"
shows "A ⊆⇩∘ vinsert x B"
using assms by auto
text‹Special properties.›
lemma vsingleton_inject:
assumes "set {x} = set {y}"
shows "x = y"
using assms by simp
lemma vsingleton_insert_inj_eq[iff]:
"set {y} = vinsert x A ⟷ x = y ∧ A ⊆⇩∘ set {y}"
by auto
lemma vsingleton_insert_inj_eq'[iff]:
"vinsert x A = set {y} ⟷ x = y ∧ A ⊆⇩∘ set {y}"
by auto
lemma vsubset_vsingletonD:
assumes "A ⊆⇩∘ set {x}"
shows "A = 0 ∨ A = set {x}"
using assms by auto
lemma vsubset_vsingleton_iff: "a ⊆⇩∘ set {x} ⟷ a = 0 ∨ a = set {x}" by auto
lemma vsubset_vdiff_vinsert: "A ⊆⇩∘ B -⇩∘ vinsert x C ⟷ A ⊆⇩∘ B -⇩∘ C ∧ x ∉⇩∘ A"
by auto
lemma vunion_vsingleton_iff:
"A ∪⇩∘ B = set {x} ⟷
A = 0 ∧ B = set {x} ∨ A = set {x} ∧ B = 0 ∨ A = set {x} ∧ B = set {x}"
by
(
metis
vsubset_vsingletonD inf_sup_ord(4) sup.idem sup_V_0_right sup_commute
)
lemma vsingleton_Un_iff:
"set {x} = A ∪⇩∘ B ⟷
A = 0 ∧ B = set {x} ∨ A = set {x} ∧ B = 0 ∨ A = set {x} ∧ B = set {x}"
by (metis vunion_vsingleton_iff sup_V_0_left sup_V_0_right sup_idem)
lemma VPow_vsingleton_iff[simp]: "VPow X = set {Y} ⟷ X = 0 ∧ Y = 0"
by (auto intro!: vsubset_antisym)
subsection‹Intersection of elements›
lemma small_VInter[simp]:
assumes "A ≠ 0"
shows "small {a. ∀x ∈⇩∘ A. a ∈⇩∘ x}"
by (metis (no_types, lifting) assms down eq0_iff mem_Collect_eq subsetI)
lemma VInter_def: "⋂⇩∘ A = (if A = 0 then 0 else set {a. ∀x ∈⇩∘ A. a ∈⇩∘ x})"
proof(cases ‹A = 0›)
case True show ?thesis unfolding True Inf_V_def by simp
next
case False
from False have "(⋂ (elts ` elts A)) = {a. ∀x ∈⇩∘ A. a ∈⇩∘ x}" by auto
with False show ?thesis unfolding Inf_V_def by auto
qed
text‹Rules.›
lemma VInter_iff[simp]:
assumes [simp]: "A ≠ 0"
shows "a ∈⇩∘ ⋂⇩∘ A ⟷ (∀x∈⇩∘A. a ∈⇩∘ x)"
unfolding VInter_def by auto
lemma VInterI[intro]:
assumes "A ≠ 0" and "⋀x. x ∈⇩∘ A ⟹ a ∈⇩∘ x"
shows "a ∈⇩∘ ⋂⇩∘ A"
using assms by auto
lemma VInter0I[intro]:
assumes "A = 0"
shows "⋂⇩∘ A = 0"
using assms unfolding VInter_def by simp
lemma VInterD[dest]:
assumes "a ∈⇩∘ ⋂⇩∘ A" and "x ∈⇩∘ A"
shows "a ∈⇩∘ x"
using assms by (cases ‹A = 0›) auto
lemma VInterE1[elim]:
assumes "a ∈⇩∘ ⋂⇩∘ A" and "x ∉⇩∘ A ⟹ R" and "a ∈⇩∘ x ⟹ R"
shows R
using assms elts_0 unfolding Inter_eq by blast
lemma VInterE2[elim]:
assumes "a ∈⇩∘ ⋂⇩∘ A"
obtains x where "a ∈⇩∘ x" and "x ∈⇩∘ A"
proof(cases ‹A = 0›)
show "(⋀x. a ∈⇩∘ x ⟹ x ∈⇩∘ A ⟹ thesis) ⟹ A = 0 ⟹ thesis"
using assms unfolding Inf_V_def by auto
show "(⋀x. a ∈⇩∘ x ⟹ x ∈⇩∘ A ⟹ thesis) ⟹ A ≠ 0 ⟹ thesis"
using assms by (meson assms VInterE1 that trad_foundation)
qed
lemma VInterE3:
assumes "a ∈⇩∘ ⋂⇩∘ A" and "(⋀y. y ∈⇩∘ A ⟹ a ∈⇩∘ y) ⟹ P"
shows P
using assms by auto
text‹Elementary properties.›
lemma VInter_Inter: "⋂⇩∘ A = set (⋂ (elts ` (elts A)))"
by (simp add: Inf_V_def ext)
lemma VInter_eq:
assumes [simp]: "A ≠ 0"
shows "⋂⇩∘ A = set {a. ∀x ∈⇩∘ A. a ∈⇩∘ x}"
unfolding VInter_def by auto
text‹Set operations.›
lemma VInter_vempty[simp]: "⋂⇩∘ 0 = 0" using VInter0I by auto
lemma VInf_vempty[simp]: "⨅{} = (0::V)" by (simp add: Inf_V_def)
lemma VInter_vdoubleton: "⋂⇩∘ (set {a, b}) = a ∩⇩∘ b"
proof(intro vsubset_antisym vsubsetI)
show "x ∈⇩∘ ⋂⇩∘ (set {a, b}) ⟹ x ∈⇩∘ a ∩⇩∘ b" for x by (elim VInterE3) auto
show "x ∈⇩∘ a ∩⇩∘ b ⟹ x ∈⇩∘ ⋂⇩∘ (set {a, b})" for x by (intro VInterI) force+
qed
lemma VInter_antimono:
assumes "B ≠ 0" and "B ⊆⇩∘ A"
shows "⋂⇩∘ A ⊆⇩∘ ⋂⇩∘ B"
using assms by blast
lemma VInter_vsubset:
assumes "⋀x. x ∈⇩∘ A ⟹ x ⊆⇩∘ B" and "A ≠ 0"
shows "⋂⇩∘ A ⊆⇩∘ B"
using assms by auto
lemma VInter_vinsert:
assumes "A ≠ 0"
shows "⋂⇩∘ (vinsert a A) = a ∩⇩∘ ⋂⇩∘ A"
using assms by (blast intro!: vsubset_antisym)
lemma VInter_vunion:
assumes "A ≠ 0" and "B ≠ 0"
shows "⋂⇩∘(A ∪⇩∘ B) = ⋂⇩∘A ∩⇩∘ ⋂⇩∘B"
using assms by (blast intro!: vsubset_antisym)
lemma VInter_vintersection:
assumes "A ∩⇩∘ B ≠ 0"
shows "⋂⇩∘ A ∪⇩∘ ⋂⇩∘ B ⊆⇩∘ ⋂⇩∘ (A ∩⇩∘ B)"
using assms by auto
lemma VInter_VPow: "⋂⇩∘ (VPow A) ⊆⇩∘ VPow (⋂⇩∘ A)" by auto
text‹Elementary properties.›
lemma VInter_lower:
assumes "x ∈⇩∘ A"
shows "⋂⇩∘ A ⊆⇩∘ x"
using assms by auto
lemma VInter_greatest:
assumes "A ≠ 0" and "⋀x. x ∈⇩∘ A ⟹ B ⊆⇩∘ x"
shows "B ⊆⇩∘ ⋂⇩∘ A"
using assms by auto
subsection‹Union of elements›
lemma Union_eq_VUnion: "⋃(elts ` elts A) = {a. ∃x ∈⇩∘ A. a ∈⇩∘ x}" by auto
lemma small_VUnion[simp]: "small {a. ∃x ∈⇩∘ A. a ∈⇩∘ x}"
by (fold Union_eq_VUnion) simp
lemma VUnion_def: "⋃⇩∘A = set {a. ∃x ∈⇩∘ A. a ∈⇩∘ x}"
unfolding Sup_V_def by auto
text‹Rules.›
lemma VUnion_iff[simp]: "A ∈⇩∘ ⋃⇩∘C ⟷ (∃x∈⇩∘C. A ∈⇩∘ x)" by auto
lemma VUnionI[intro]:
assumes "x ∈⇩∘ A" and "a ∈⇩∘ x"
shows "a ∈⇩∘ ⋃⇩∘A"
using assms by auto
lemma VUnionE[elim!]:
assumes "a ∈⇩∘ ⋃⇩∘A" and "⋀x. a ∈⇩∘ x ⟹ x ∈⇩∘ A ⟹ R"
shows R
using assms by clarsimp
text‹Elementary properties.›
lemma VUnion_Union: "⋃⇩∘A = set (⋃ (elts ` (elts A)))"
by (simp add: Inf_V_def ext)
text‹Set operations.›
lemma VUnion_vempty[simp]: "⋃⇩∘0 = 0" by simp
lemma VUnion_vsingleton[simp]: "⋃⇩∘(set {a}) = a" by simp
lemma VUnion_vdoubleton[simp]: "⋃⇩∘(set {a, b}) = a ∪⇩∘ b" by auto
lemma VUnion_mono:
assumes "A ⊆⇩∘ B"
shows "⋃⇩∘A ⊆⇩∘ ⋃⇩∘B"
using assms by auto
lemma VUnion_vinsert: "⋃⇩∘(vinsert x A) = x ∪⇩∘ ⋃⇩∘A" by auto
lemma VUnion_vintersection: "⋃⇩∘(A ∩⇩∘ B) ⊆⇩∘ ⋃⇩∘A ∩⇩∘ ⋃⇩∘B" by auto
lemma VUnion_vunion[simp]: "⋃⇩∘(A ∪⇩∘ B) = ⋃⇩∘A ∪⇩∘ ⋃⇩∘B" by auto
lemma VUnion_VPow[simp]: "⋃⇩∘(VPow A) = A" by auto
text‹Special properties.›
lemma VUnion_vempty_conv_left: "0 = ⋃⇩∘A ⟷ (∀x∈⇩∘A. x = 0)" by auto
lemma VUnion_vempty_conv_right: "⋃⇩∘A = 0 ⟷ (∀x∈⇩∘A. x = 0)" by auto
lemma vsubset_VPow_VUnion: "A ⊆⇩∘ VPow (⋃⇩∘A)" by auto
lemma VUnion_vsubsetI:
assumes "⋀x. x ∈⇩∘ A ⟹ ∃y. y ∈⇩∘ B ∧ x ⊆⇩∘ y"
shows "⋃⇩∘A ⊆⇩∘ ⋃⇩∘B"
using assms by auto
lemma VUnion_upper:
assumes "x ∈⇩∘ A"
shows "x ⊆⇩∘ ⋃⇩∘A"
using assms by auto
lemma VUnion_least:
assumes "⋀x. x ∈⇩∘ A ⟹ x ⊆⇩∘ B"
shows "⋃⇩∘A ⊆⇩∘ B"
using assms by (fact Sup_least)
subsection‹Pairs›
subsubsection‹Further results›
lemma small_elts_of_set[simp, intro]:
assumes "small x"
shows "elts (set x) = x"
by (simp add: assms)
lemma small_vpair[intro, simp]:
assumes "small {a. P a}"
shows "small {⟨a, b⟩ | a. P a}"
by (subgoal_tac ‹{⟨a, b⟩ | a. P a} = (λa. ⟨a, b⟩) ` {a. P a}›)
(auto simp: assms)
subsubsection‹‹vpairs››
definition vpairs :: "V ⇒ V" where
"vpairs r = set {x. x ∈⇩∘ r ∧ (∃a b. x = ⟨a, b⟩)}"
lemma small_vpairs[simp]: "small {⟨a, b⟩ | a b. ⟨a, b⟩ ∈⇩∘ r}"
by (rule down[of _ r]) clarsimp
text‹Rules.›
lemma vpairsI[intro]:
assumes "x ∈⇩∘ r" and "x = ⟨a, b⟩"
shows "x ∈⇩∘ vpairs r"
using assms unfolding vpairs_def by auto
lemma vpairsD[dest]:
assumes "x ∈⇩∘ vpairs r"
shows "x ∈⇩∘ r" and "∃a b. x = ⟨a, b⟩"
using assms unfolding vpairs_def by auto
lemma vpairsE[elim]:
assumes "x ∈⇩∘ vpairs r"
obtains a b where "x = ⟨a, b⟩" and "⟨a, b⟩ ∈⇩∘ r"
using assms unfolding vpairs_def by auto
lemma vpairs_iff: "x ∈⇩∘ vpairs r ⟷ x ∈⇩∘ r ∧ (∃a b. x = ⟨a, b⟩)" by auto
text‹Elementary properties.›
lemma vpairs_iff_elts: "⟨a, b⟩ ∈⇩∘ vpairs r ⟷ ⟨a, b⟩ ∈⇩∘ r" by auto
lemma vpairs_iff_pairs: "⟨a, b⟩ ∈⇩∘ vpairs r ⟷ (a, b) ∈ pairs r"
by (simp add: vpairs_iff_elts pairs_iff_elts)
text‹Set operations.›
lemma vpairs_vempty[simp]: "vpairs 0 = 0" by auto
lemma vpairs_vsingleton[simp]: "vpairs (set {⟨a, b⟩}) = set {⟨a, b⟩}" by auto
lemma vpairs_vinsert: "vpairs (vinsert ⟨a, b⟩ A) = set {⟨a, b⟩} ∪⇩∘ vpairs A"
by auto
lemma vpairs_mono:
assumes "r ⊆⇩∘ s"
shows "vpairs r ⊆⇩∘ vpairs s"
using assms by blast
lemma vpairs_vunion: "vpairs (A ∪⇩∘ B) = vpairs A ∪⇩∘ vpairs B" by auto
lemma vpairs_vintersection: "vpairs (A ∩⇩∘ B) = vpairs A ∩⇩∘ vpairs B" by auto
lemma vpairs_vdiff: "vpairs (A -⇩∘ B) = vpairs A -⇩∘ vpairs B" by auto
text‹Special properties.›
lemma vpairs_ex_vfst:
assumes "x ∈⇩∘ vpairs r"
shows "∃b. ⟨vfst x, b⟩ ∈⇩∘ r"
using assms by force
lemma vpairs_ex_vsnd:
assumes "y ∈⇩∘ vpairs r"
shows "∃a. ⟨a, vsnd y⟩ ∈⇩∘ r"
using assms by force
subsection‹Cartesian products›
text‹
The following lemma is based on Theorem 6.2 from
\cite{takeuti_introduction_1971}.
›
lemma vtimes_vsubset_VPowVPow: "A ×⇩∘ B ⊆⇩∘ VPow (VPow (A ∪⇩∘ B))"
proof(intro vsubsetI)
fix x assume "x ∈⇩∘ A ×⇩∘ B"
then obtain a b where x_def: "x = ⟨a, b⟩" and "a ∈⇩∘ A" and "b ∈⇩∘ B" by clarsimp
then show "x ∈⇩∘ VPow (VPow (A ∪⇩∘ B))"
unfolding x_def vpair_def by auto
qed
subsection‹Pairwise›
definition vpairwise :: "(V ⇒ V ⇒ bool) ⇒ V ⇒ bool"
where "vpairwise R S ⟷ (∀x∈⇩∘S. ∀y∈⇩∘S. x ≠ y ⟶ R x y)"
text‹Rules.›
lemma vpairwiseI[intro?]:
assumes "⋀x y. x ∈⇩∘ S ⟹ y ∈⇩∘ S ⟹ x ≠ y ⟹ R x y"
shows "vpairwise R S"
using assms by (simp add: vpairwise_def)
lemma vpairwiseD[dest]:
assumes "vpairwise R S" and "x ∈⇩∘ S" and "y ∈⇩∘ S" and "x ≠ y"
shows "R x y" and "R y x"
using assms unfolding vpairwise_def by auto
text‹Elementary properties.›
lemma vpairwise_trivial[simp]: "vpairwise (λi j. j ≠ i) I"
by (auto simp: vpairwise_def)
text‹Set operations.›
lemma vpairwise_vempty[simp]: "vpairwise P 0" by (force intro: vpairwiseI)
lemma vpairwise_vsingleton[simp]: "vpairwise P (set {A})"
by (simp add: vpairwise_def)
lemma vpairwise_vinsert:
"vpairwise r (vinsert x s) ⟷
(∀y. y ∈⇩∘ s ∧ y ≠ x ⟶ r x y ∧ r y x) ∧ vpairwise r s"
by (intro iffI conjI allI impI; (elim conjE | tactic‹all_tac›))
(auto simp: vpairwise_def)
lemma vpairwise_vsubset:
assumes "vpairwise P S" and "T ⊆⇩∘ S"
shows "vpairwise P T"
using assms by (metis less_eq_V_def subset_eq vpairwiseD(2) vpairwiseI)
lemma vpairwise_mono:
assumes "vpairwise P A" and "⋀x y. P x y ⟹ Q x y" and "B ⊆⇩∘ A"
shows "vpairwise Q B"
using assms by (simp add: less_eq_V_def subset_eq vpairwiseD(2) vpairwiseI)
subsection‹Disjoint sets›
abbreviation vdisjnt :: "V ⇒ V ⇒ bool"
where "vdisjnt A B ≡ A ∩⇩∘ B = 0"
text‹Elementary properties.›
lemma vdisjnt_sym:
assumes "vdisjnt A B"
shows "vdisjnt B A"
using assms by blast
lemma vdisjnt_iff: "vdisjnt A B ⟷ (∀x. ~ (x ∈⇩∘ A ∧ x ∈⇩∘ B))" by auto
text‹Set operations.›
lemma vdisjnt_vempty1[simp]: "vdisjnt 0 A"
and vdisjnt_vempty2[simp]: "vdisjnt A 0"
by auto
lemma vdisjnt_singleton0[simp]: "vdisjnt (set {a}) (set {b}) ⟷ a ≠ b"
and vdisjnt_singleton1[simp]: "vdisjnt (set {a}) A ⟷ a ∉⇩∘ A"
and vdisjnt_singleton2[simp]: "vdisjnt A (set {a}) ⟷ a ∉⇩∘ A"
by force+
lemma vdisjnt_vinsert_left: "vdisjnt (vinsert a X) Y ⟷ a ∉⇩∘ Y ∧ vdisjnt X Y"
by (metis vdisjnt_iff vdisjnt_sym vinsertE1 vinsertI2 vinsert_iff)
lemma vdisjnt_vinsert_right: "vdisjnt Y (vinsert a X) ⟷ a ∉⇩∘ Y ∧ vdisjnt Y X"
using vdisjnt_sym vdisjnt_vinsert_left by meson
lemma vdisjnt_vsubset_left:
assumes "vdisjnt X Y" and "Z ⊆⇩∘ X"
shows "vdisjnt Z Y"
using assms by (auto intro!: vsubset_antisym)
lemma vdisjnt_vsubset_right:
assumes "vdisjnt X Y" and "Z ⊆⇩∘ Y"
shows "vdisjnt X Z"
using assms by (auto intro!: vsubset_antisym)
lemma vdisjnt_vunion_left: "vdisjnt (A ∪⇩∘ B) C ⟷ vdisjnt A C ∧ vdisjnt B C"
by auto
lemma vdisjnt_vunion_right: "vdisjnt C (A ∪⇩∘ B) ⟷ vdisjnt C A ∧ vdisjnt C B"
by auto
text‹Special properties.›
lemma vdisjnt_vemptyI[intro]:
assumes "⋀x. x ∈⇩∘ A ⟹ x ∈⇩∘ B ⟹ False"
shows "vdisjnt A B"
using assms by (auto intro!: vsubset_antisym)
lemma vdisjnt_self_iff_vempty[simp]: "vdisjnt S S ⟷ S = 0" by auto
lemma vdisjntI:
assumes "⋀x y. x ∈⇩∘ A ⟹ y ∈⇩∘ B ⟹ x ≠ y"
shows "vdisjnt A B"
using assms by auto
lemma vdisjnt_nin_right:
assumes "vdisjnt A B" and "a ∈⇩∘ A"
shows "a ∉⇩∘ B"
using assms by auto
lemma vdisjnt_nin_left:
assumes "vdisjnt B A" and "a ∈⇩∘ A"
shows "a ∉⇩∘ B"
using assms by auto
text‹\newpage›
end
Theory CZH_Sets_Nat
section‹Further properties of natural numbers›
theory CZH_Sets_Nat
imports CZH_Sets_Sets
begin
subsection‹Background›
text‹
The section exposes certain fundamental properties of natural numbers and
provides convenience utilities for doing arithmetic within the type \<^typ>‹V›.
Many of the results that are presented in this sections were carried over
(with amendments) from the theory ‹Nat› that can be found in the main
library of Isabelle/HOL.
›
notation ord_of_nat (‹_⇩ℕ› [999] 999)
named_theorems nat_omega_simps
declare One_nat_def[simp del]
abbreviation (input) vpfst where "vpfst a ≡ a⦇0⦈"
abbreviation (input) vpsnd where "vpsnd a ≡ a⦇1⇩ℕ⦈"
abbreviation (input) vpthrd where "vpthrd a ≡ a⦇2⇩ℕ⦈"
subsection‹Conversion between \<^typ>‹V› and ‹nat››
subsubsection‹Primitive arithmetic›
lemma ord_of_nat_plus[nat_omega_simps]: "a⇩ℕ + b⇩ℕ = (a + b)⇩ℕ"
by (induct b) (simp_all add: plus_V_succ_right)
lemma ord_of_nat_times[nat_omega_simps]: "a⇩ℕ * b⇩ℕ = (a * b)⇩ℕ"
by (induct b) (simp_all add: mult_succ nat_omega_simps)
lemma ord_of_nat_succ[nat_omega_simps]: "succ (a⇩ℕ) = (Suc a)⇩ℕ" by auto
lemmas [nat_omega_simps] = nat_cadd_eq_add
lemma ord_of_nat_csucc[nat_omega_simps]: "csucc (a⇩ℕ) = succ (a⇩ℕ)"
using finite_csucc by blast
lemma ord_of_nat_succ_vempty[nat_omega_simps]: "succ 0 = 1⇩ℕ" by auto
lemma ord_of_nat_vone[nat_omega_simps]: "1 = 1⇩ℕ" by auto
subsubsection‹Transfer›
definition cr_omega :: "V ⇒ nat ⇒ bool"
where "cr_omega a b ⟷ (a = ord_of_nat b)"
text‹Transfer setup.›
lemma cr_omega_right_total[transfer_rule]: "right_total cr_omega"
unfolding cr_omega_def right_total_def by simp
lemma cr_omega_bi_unqie[transfer_rule]: "bi_unique cr_omega"
unfolding cr_omega_def bi_unique_def
by (simp add: inj_eq inj_ord_of_nat)
lemma omega_transfer_domain_rule[transfer_domain_rule]:
"Domainp cr_omega = (λx. x ∈⇩∘ ω)"
unfolding cr_omega_def by (auto simp: elts_ω)
lemma omega_transfer[transfer_rule]:
"(rel_set cr_omega) (elts ω) (UNIV::nat set)"
unfolding cr_omega_def rel_set_def by (simp add: elts_ω)
lemma omega_of_real_transfer[transfer_rule]: "cr_omega (ord_of_nat a) a"
unfolding cr_omega_def by auto
text‹Operations.›
lemma omega_succ_transfer[transfer_rule]:
includes lifting_syntax
shows "(cr_omega ===> cr_omega) succ Suc"
proof(intro rel_funI, unfold cr_omega_def)
fix x y assume prems: "x = y⇩ℕ"
show "succ x = Suc y⇩ℕ" unfolding prems ord_of_nat_succ[symmetric] ..
qed
lemma omega_plus_transfer[transfer_rule]:
includes lifting_syntax
shows "(cr_omega ===> cr_omega ===> cr_omega) (+) (+)"
by (intro rel_funI, unfold cr_omega_def) (simp add: nat_omega_simps)
lemma omega_mult_transfer[transfer_rule]:
includes lifting_syntax
shows "(cr_omega ===> cr_omega ===> cr_omega) (*) (*)"
by (intro rel_funI, unfold cr_omega_def) (simp add: nat_omega_simps)
lemma ord_of_nat_card_transfer[transfer_rule]:
includes lifting_syntax
shows "(rel_set (=) ===> cr_omega) (λx. ord_of_nat (card x)) card"
by (intro rel_funI) (simp add: cr_omega_def rel_set_eq)
subsection‹Elementary results›
lemma ord_of_nat_vempty: "0 = 0⇩ℕ" by auto
lemma set_vzero_eq_ord_of_nat_vone: "set {0} = 1⇩ℕ"
by (metis elts_1 set_of_elts ord_of_nat_vone)
lemma vone_in_omega[simp]: "1 ∈⇩∘ ω" unfolding ω_def by force
lemma nat_of_omega:
assumes "n ∈⇩∘ ω"
obtains m where "n = m⇩ℕ"
using assms unfolding ω_def by clarsimp
lemma omega_prev:
assumes "n ∈⇩∘ ω" and "0 ∈⇩∘ n"
obtains k where "n = succ k"
proof-
from assms nat_of_omega obtain m where "n = m⇩ℕ" by auto
with assms(2) obtain m' where "m = Suc m'"
unfolding less_V_def by (auto dest: gr0_implies_Suc)
with that show ?thesis unfolding ‹n = m⇩ℕ› using ord_of_nat.simps(2) by blast
qed
lemma omega_vplus_commutative:
assumes "a ∈⇩∘ ω" and "b ∈⇩∘ ω"
shows "a + b = b + a"
using assms by (metis Groups.add_ac(2) nat_of_omega ord_of_nat_plus)
lemma omega_vinetrsection[intro]:
assumes "m ∈⇩∘ ω" and "n ∈⇩∘ ω"
shows "m ∩⇩∘ n ∈⇩∘ ω"
proof-
from nat_into_Ord[OF assms(1)] nat_into_Ord[OF assms(2)] Ord_linear_le
consider "m ⊆⇩∘ n" | "n ⊆⇩∘ m"
by auto
then show ?thesis by cases (simp_all add: assms inf.absorb1 inf.absorb2)
qed
subsection‹Induction›
lemma omega_induct_all[consumes 1, case_names step]:
assumes "n ∈⇩∘ ω" and "⋀x. ⟦x ∈⇩∘ ω; ⋀y. y ∈⇩∘ x ⟹ P y⟧ ⟹ P x"
shows "P n"
using assms by (metis Ord_ω Ord_induct Ord_linear Ord_trans nat_into_Ord)
lemma omega_induct[consumes 1, case_names 0 succ]:
assumes "n ∈⇩∘ ω" and "P 0" and "⋀n. ⟦ n ∈⇩∘ ω; P n ⟧ ⟹ P (succ n)"
shows "P n"
using assms(1,3)
proof(induct rule: omega_induct_all)
case (step x) show ?case
proof(cases ‹x = 0›)
case True with assms(2) show ?thesis by simp
next
case False
with step(1) have "0 ∈⇩∘ x" by (simp add: mem_0_Ord)
with ‹x ∈⇩∘ ω› obtain y where x_def: "x = succ y" by (elim omega_prev)
with elts_succ step.hyps(1) have "y ∈⇩∘ ω" by (blast intro: Ord_trans)
have "y ∈⇩∘ x" by (simp add: ‹x = succ y›)
have "P y" by (auto intro: step.prems step.hyps(2)[OF ‹y ∈⇩∘ x›])
from step.prems[OF ‹y ∈⇩∘ ω› ‹P y›, folded x_def] show "P x" .
qed
qed
subsection‹Methods›
text‹
The following methods provide an infrastructure for working with goals of the
form ‹a ∈⇩∘ n⇩ℕ ⟹ P a›.
›
lemma in_succE:
assumes "a ∈⇩∘ succ n" and "⋀a. a ∈⇩∘ n ⟹ P a" and "P n"
shows "P a"
using assms by auto
method Suc_of_numeral =
(
unfold numeral.simps add.assoc,
use nothing in ‹unfold Suc_eq_plus1_left[symmetric], unfold One_nat_def›
)
method succ_of_numeral =
(
Suc_of_numeral,
use nothing in ‹unfold ord_of_nat_succ[symmetric] ord_of_nat_zero›
)
method numeral_of_succ =
(
unfold nat_omega_simps,
use nothing in
‹
unfold numeral.simps[symmetric] Suc_numeral add_num_simps,
(unfold numerals(1))?
›
)
method elim_in_succ =
(
(
elim in_succE;
use nothing in ‹(unfold triv_forall_equality)?; (numeral_of_succ)?›
),
simp
)
method elim_in_numeral = (succ_of_numeral, use nothing in ‹elim_in_succ›)
subsection‹Auxiliary›
lemma two: "2⇩ℕ = set {0, 1⇩ℕ}" by force
lemma three: "3⇩ℕ = set {0, 1⇩ℕ, 2⇩ℕ}" by force
lemma four: "4⇩ℕ = set {0, 1⇩ℕ, 2⇩ℕ, 3⇩ℕ}" by force
lemma two_vdiff_zero[simp]: "set {0, 1⇩ℕ} -⇩∘ set {0} = set {1⇩ℕ}" by auto
lemma two_vdiff_one[simp]: "set {0, 1⇩ℕ} -⇩∘ set {1⇩ℕ} = set {0}" by auto
text‹\newpage›
end
Theory CZH_Sets_BRelations
section‹Elementary binary relations›
theory CZH_Sets_BRelations
imports CZH_Sets_Sets
keywords "mk_VLambda" :: thy_defn
and "|app" "|vsv" "|vdomain"
begin
subsection‹Background›
text‹
This section presents a theory of binary relations internalized in the
type \<^typ>‹V› and exposes elementary properties of two special types of
binary relations: single-valued binary relations and injective single-valued
binary relations.
Many of the results that are presented in this section were carried over
(with amendments) from the theories \<^text>‹Set› and \<^text>‹Relation› in the main
library.
›
subsection‹Constructors›
subsubsection‹Identity relation›
definition vid_on :: "V ⇒ V"
where "vid_on A = set {⟨a, a⟩ | a. a ∈⇩∘ A}"
lemma vid_on_small[simp]: "small {⟨a, a⟩ | a. a ∈⇩∘ A}"
by (rule down[of _ ‹A ×⇩∘ A›]) blast
text‹Rules.›
lemma vid_on_eqI:
assumes "a = b" and "a ∈⇩∘ A"
shows "⟨a, b⟩ ∈⇩∘ vid_on A"
using assms by (simp add: vid_on_def)
lemma vid_onI[intro!]:
assumes "a ∈⇩∘ A"
shows "⟨a, a⟩ ∈⇩∘ vid_on A"
by (rule vid_on_eqI) (simp_all add: assms)
lemma vid_onD[dest!]:
assumes "⟨a, a⟩ ∈⇩∘ vid_on A"
shows "a ∈⇩∘ A"
using assms unfolding vid_on_def by auto
lemma vid_onE[elim!]:
assumes "x ∈⇩∘ vid_on A" and "∃a∈⇩∘A. x = ⟨a, a⟩ ⟹ P"
shows P
using assms unfolding vid_on_def by auto
lemma vid_on_iff: "⟨a, b⟩ ∈⇩∘ vid_on A ⟷ a = b ∧ a ∈⇩∘ A" by auto
text‹Set operations.›
lemma vid_on_vempty[simp]: "vid_on 0 = 0" by auto
lemma vid_on_vsingleton[simp]: "vid_on (set {a}) = set {⟨a, a⟩}" by auto
lemma vid_on_vdoubleton[simp]: "vid_on (set {a, b}) = set {⟨a, a⟩, ⟨b, b⟩}"
by (auto simp: vinsert_set_insert_eq)
lemma vid_on_mono:
assumes "A ⊆⇩∘ B"
shows "vid_on A ⊆⇩∘ vid_on B"
using assms by auto
lemma vid_on_vinsert: "(vinsert ⟨a, a⟩ (vid_on A)) = (vid_on (vinsert a A))"
by auto
lemma vid_on_vintersection: "vid_on (A ∩⇩∘ B) = vid_on A ∩⇩∘ vid_on B" by auto
lemma vid_on_vunion: "vid_on (A ∪⇩∘ B) = vid_on A ∪⇩∘ vid_on B" by auto
lemma vid_on_vdiff: "vid_on (A -⇩∘ B) = vid_on A -⇩∘ vid_on B" by auto
text‹Special properties.›
lemma vid_on_vsubset_vtimes: "vid_on A ⊆⇩∘ A ×⇩∘ A" by clarsimp
subsubsection‹Constant function›
definition vconst_on :: "V ⇒ V ⇒ V"
where "vconst_on A c = set {⟨a, c⟩ | a. a ∈⇩∘ A}"
lemma small_vconst_on[simp]: "small {⟨a, c⟩ | a. a ∈⇩∘ A}"
by (rule down[of _ ‹A ×⇩∘ set {c}›]) auto
text‹Rules.›
lemma vconst_onI[intro!]:
assumes "a ∈⇩∘ A"
shows "⟨a, c⟩ ∈⇩∘ vconst_on A c"
using assms unfolding vconst_on_def by simp
lemma vconst_onD[dest!]:
assumes "⟨a, c⟩ ∈⇩∘ vconst_on A c"
shows "a ∈⇩∘ A"
using assms unfolding vconst_on_def by simp
lemma vconst_onE[elim!]:
assumes "x ∈⇩∘ vconst_on A c"
obtains a where "a ∈⇩∘ A" and "x = ⟨a, c⟩"
using assms unfolding vconst_on_def by auto
lemma vconst_on_iff: "⟨a, c⟩ ∈⇩∘ vconst_on A c ⟷ a ∈⇩∘ A" by auto
text‹Set operations.›
lemma vconst_on_vempty[simp]: "vconst_on 0 c = 0"
unfolding vconst_on_def by auto
lemma vconst_on_vsingleton[simp]: "vconst_on (set {a}) c = set {⟨a, c⟩}" by auto
lemma vconst_on_vdoubleton[simp]: "vconst_on (set {a, b}) c = set {⟨a, c⟩, ⟨b, c⟩}"
by (auto simp: vinsert_set_insert_eq)
lemma vconst_on_mono:
assumes "A ⊆⇩∘ B"
shows "vconst_on A c ⊆⇩∘ vconst_on B c"
using assms by auto
lemma vconst_on_vinsert:
"(vinsert ⟨a, c⟩ (vconst_on A c)) = (vconst_on (vinsert a A) c)"
by auto
lemma vconst_on_vintersection:
"vconst_on (A ∩⇩∘ B) c = vconst_on A c ∩⇩∘ vconst_on B c"
by auto
lemma vconst_on_vunion: "vconst_on (A ∪⇩∘ B) c = vconst_on A c ∪⇩∘ vconst_on B c"
by auto
lemma vconst_on_vdiff: "vconst_on (A -⇩∘ B) c = vconst_on A c -⇩∘ vconst_on B c"
by auto
text‹Special properties.›
lemma vconst_on_eq_vtimes: "vconst_on A c = A ×⇩∘ set {c}"
by standard (auto intro!: vsubset_antisym)
subsubsection‹‹VLambda››
text‹Rules.›
lemma VLambdaI[intro!]:
assumes "a ∈⇩∘ A"
shows "⟨a, f a⟩ ∈⇩∘ (λa∈⇩∘A. f a)"
using assms unfolding VLambda_def by auto
lemma VLambdaD[dest!]:
assumes "⟨a, f a⟩ ∈⇩∘ (λa∈⇩∘A. f a)"
shows "a ∈⇩∘ A"
using assms unfolding VLambda_def by auto
lemma VLambdaE[elim!]:
assumes "x ∈⇩∘ (λa∈⇩∘A. f a)"
obtains a where "a ∈⇩∘ A" and "x = ⟨a, f a⟩"
using assms unfolding VLambda_def by auto
lemma VLambda_iff1: "x ∈⇩∘ (λa∈⇩∘A. f a) ⟷ (∃a∈⇩∘A. x = ⟨a, f a⟩)" by auto
lemma VLambda_iff2: "⟨a, b⟩ ∈⇩∘ (λa∈⇩∘A. f a) ⟷ b = f a ∧ a ∈⇩∘ A" by auto
lemma small_VLambda[simp]: "small {⟨a, f a⟩ | a. a ∈⇩∘ A}" by auto
lemma VLambda_set_def: "(λa∈⇩∘A. f a) = set {⟨a, f a⟩ | a. a ∈⇩∘ A}" by auto
text‹Set operations.›
lemma VLambda_vempty[simp]: "(λa∈⇩∘0. f a) = 0" by auto
lemma VLambda_vsingleton: "(λa∈⇩∘set {a}. f a) = set {⟨a, f a⟩}"
by auto
lemma VLambda_vdoubleton:
"(λa∈⇩∘set {a, b}. f a) = set {⟨a, f a⟩, ⟨b, f b⟩}"
by (auto simp: vinsert_set_insert_eq)
lemma VLambda_mono:
assumes "A ⊆⇩∘ B"
shows "(λa∈⇩∘A. f a) ⊆⇩∘ (λa∈⇩∘B. f a)"
using assms by auto
lemma VLambda_vinsert:
"(λa∈⇩∘vinsert a A. f a) = (λa∈⇩∘set {a}. f a) ∪⇩∘ (λa∈⇩∘A. f a)"
by auto
lemma VLambda_vintersection: "(λa∈⇩∘A ∩⇩∘ B. f a) = (λa∈⇩∘A. f a) ∩⇩∘ (λa∈⇩∘B. f a)"
by auto
lemma VLambda_vunion: "(λa∈⇩∘A ∪⇩∘ B. f a) = (λa∈⇩∘A. f a) ∪⇩∘ (λa∈⇩∘B. f a)" by auto
lemma VLambda_vdiff: "(λa∈⇩∘A -⇩∘ B. f a) = (λa∈⇩∘A. f a) -⇩∘ (λa∈⇩∘B. f a)" by auto
text‹Connections.›
lemma VLambda_vid_on: "(λa∈⇩∘A. a) = vid_on A" by auto
lemma VLambda_vconst_on: "(λa∈⇩∘A. c) = vconst_on A c" by auto
subsubsection‹Composition›
definition vcomp :: "V ⇒ V ⇒ V" (infixr "∘⇩∘" 75)
where "r ∘⇩∘ s = set {⟨a, c⟩ | a c. ∃b. ⟨a, b⟩ ∈⇩∘ s ∧ ⟨b, c⟩ ∈⇩∘ r}"
notation vcomp (infixr ‹∘⇩∘› 75)
lemma vcomp_small[simp]: "small {⟨a, c⟩ | a c. ∃b. ⟨a, b⟩ ∈⇩∘ s ∧ ⟨b, c⟩ ∈⇩∘ r}"
(is ‹small ?s›)
proof-
define comp' where "comp' = (λ⟨⟨a, b⟩, ⟨c, d⟩⟩. ⟨a, d⟩)"
have "small (elts (vpairs (s ×⇩∘ r)))" by simp
then have small_comp: "small (comp' ` elts (vpairs (s ×⇩∘ r)))" by simp
have ss: "?s ⊆ (comp' ` elts (vpairs (s ×⇩∘ r)))"
proof
fix x assume "x ∈ ?s"
then obtain a b c where x_def: "x = ⟨a, c⟩"
and "⟨a, b⟩ ∈⇩∘ s"
and "⟨b, c⟩ ∈⇩∘ r"
by auto
then have abbc: "⟨⟨a, b⟩, ⟨b, c⟩⟩ ∈⇩∘ vpairs (s ×⇩∘ r)"
by (simp add: vpairs_iff_elts)
have x_def': "x = comp' ⟨⟨a, b⟩, ⟨b, c⟩⟩" unfolding comp'_def x_def by auto
then show "x ∈ comp' ` elts (vpairs (s ×⇩∘ r))"
unfolding x_def' using abbc by auto
qed
with small_comp show ?thesis by (metis (lifting) smaller_than_small)
qed
text‹Rules.›
lemma vcompI[intro!]:
assumes "⟨b, c⟩ ∈⇩∘ r" and "⟨a, b⟩ ∈⇩∘ s"
shows "⟨a, c⟩ ∈⇩∘ r ∘⇩∘ s"
using assms unfolding vcomp_def by auto
lemma vcompD[dest!]:
assumes "⟨a, c⟩ ∈⇩∘ r ∘⇩∘ s"
shows "∃b. ⟨b, c⟩ ∈⇩∘ r ∧ ⟨a, b⟩ ∈⇩∘ s"
using assms unfolding vcomp_def by auto
lemma vcompE[elim!]:
assumes "ac ∈⇩∘ r ∘⇩∘ s"
obtains a b c where "ac = ⟨a, c⟩" and "⟨a, b⟩ ∈⇩∘ s" and "⟨b, c⟩ ∈⇩∘ r"
using assms unfolding vcomp_def by clarsimp
text‹Elementary properties.›
lemma vcomp_assoc: "(r ∘⇩∘ s) ∘⇩∘ t = r ∘⇩∘ (s ∘⇩∘ t)" by auto
text‹Set operations.›
lemma vcomp_vempty_left[simp]: "0 ∘⇩∘ r = 0" by auto
lemma vcomp_vempty_right[simp]: "r ∘⇩∘ 0 = 0" by auto
lemma vcomp_mono:
assumes "r' ⊆⇩∘ r" and "s' ⊆⇩∘ s"
shows "r' ∘⇩∘ s' ⊆⇩∘ r ∘⇩∘ s"
using assms by auto
lemma vcomp_vinsert_left[simp]:
"(vinsert ⟨a, b⟩ s) ∘⇩∘ r = (set {⟨a, b⟩} ∘⇩∘ r) ∪⇩∘ (s ∘⇩∘ r)"
by auto
lemma vcomp_vinsert_right[simp]:
"r ∘⇩∘ (vinsert ⟨a, b⟩ s) = (r ∘⇩∘ set {⟨a, b⟩}) ∪⇩∘ (r ∘⇩∘ s)"
by auto
lemma vcomp_vunion_left[simp]: "(s ∪⇩∘ t) ∘⇩∘ r = (s ∘⇩∘ r) ∪⇩∘ (t ∘⇩∘ r)" by auto
lemma vcomp_vunion_right[simp]: "r ∘⇩∘ (s ∪⇩∘ t) = (r ∘⇩∘ s) ∪⇩∘ (r ∘⇩∘ t)" by auto
text‹Connections.›
lemma vcomp_vid_on_idem[simp]: "vid_on A ∘⇩∘ vid_on A = vid_on A" by auto
lemma vcomp_vid_on[simp]: "vid_on A ∘⇩∘ vid_on B = vid_on (A ∩⇩∘ B)" by auto
lemma vcomp_vconst_on_vid_on[simp]: "vconst_on A c ∘⇩∘ vid_on A = vconst_on A c"
by auto
lemma vcomp_VLambda_vid_on[simp]: "(λa∈⇩∘A. f a) ∘⇩∘ vid_on A = (λa∈⇩∘A. f a)"
by auto
text‹Special properties.›
lemma vcomp_vsubset_vtimes:
assumes "r ⊆⇩∘ B ×⇩∘ C" and "s ⊆⇩∘ A ×⇩∘ B"
shows "r ∘⇩∘ s ⊆⇩∘ A ×⇩∘ C"
using assms by auto
lemma vcomp_obtain_middle[elim]:
assumes "⟨a, c⟩ ∈⇩∘ r ∘⇩∘ s"
obtains b where "⟨a, b⟩ ∈⇩∘ s" and "⟨b, c⟩ ∈⇩∘ r"
using assms by auto
subsubsection‹Converse relation›
definition vconverse :: "V ⇒ V"
where "vconverse A = (λr∈⇩∘A. set {⟨b, a⟩ | a b. ⟨a, b⟩ ∈⇩∘ r})"
abbreviation app_vconverse (‹(_¯⇩∘)› [1000] 999)
where "r¯⇩∘ ≡ vconverse (set {r}) ⦇r⦈"
lemma app_vconverse_def: "r¯⇩∘ = set {⟨b, a⟩ | a b. ⟨a, b⟩ ∈⇩∘ r}"
unfolding vconverse_def by simp
lemma vconverse_small[simp]: "small {⟨b, a⟩ | a b. ⟨a, b⟩ ∈⇩∘ r}"
proof-
have eq: "{⟨b, a⟩ | a b. ⟨a, b⟩ ∈⇩∘ r} = (λ⟨a, b⟩. ⟨b, a⟩) ` elts (vpairs r)"
proof(rule subset_antisym; rule subsetI, unfold mem_Collect_eq)
fix x assume "x ∈ (λ⟨a, b⟩. ⟨b, a⟩) ` elts (vpairs r)"
then obtain a b where "⟨a, b⟩ ∈⇩∘ vpairs r" and "x = (λ⟨a, b⟩. ⟨b, a⟩) ⟨a, b⟩"
by blast
then show "∃a b. x = ⟨b, a⟩ ∧ ⟨a, b⟩ ∈⇩∘ r" by auto
qed (use image_iff vpairs_iff_elts in fastforce)
show ?thesis unfolding eq by (rule replacement) auto
qed
text‹Rules.›
lemma vconverseI[intro!]:
assumes "r ∈⇩∘ A"
shows "⟨r, r¯⇩∘⟩ ∈⇩∘ vconverse A"
using assms unfolding vconverse_def by auto
lemma vconverseD[dest]:
assumes "⟨r, s⟩ ∈⇩∘ vconverse A"
shows "r ∈⇩∘ A" and "s = r¯⇩∘"
using assms unfolding vconverse_def by auto
lemma vconverseE[elim]:
assumes "x ∈⇩∘ vconverse A"
obtains r where "x = ⟨r, r¯⇩∘⟩" and "r ∈⇩∘ A"
using assms unfolding vconverse_def by auto
lemma app_vconverseI[sym, intro!]:
assumes "⟨a, b⟩ ∈⇩∘ r"
shows "⟨b, a⟩ ∈⇩∘ r¯⇩∘"
using assms unfolding vconverse_def by auto
lemma app_vconverseD[sym, dest]:
assumes "⟨a, b⟩ ∈⇩∘ r¯⇩∘"
shows "⟨b, a⟩ ∈⇩∘ r"
using assms unfolding vconverse_def by simp
lemma app_vconverseE[elim!]:
assumes "x ∈⇩∘ r¯⇩∘"
obtains a b where "x = ⟨b, a⟩" and "⟨a, b⟩ ∈⇩∘ r"
using assms unfolding vconverse_def by auto
lemma vconverse_iff: "⟨b, a⟩ ∈⇩∘ r¯⇩∘ ⟷ ⟨a, b⟩ ∈⇩∘ r" by auto
text‹Set operations.›
lemma vconverse_vempty[simp]: "0¯⇩∘ = 0" by auto
lemma vconverse_vsingleton: "(set {⟨a, b⟩})¯⇩∘ = set {⟨b, a⟩}" by auto
lemma vconverse_vdoubleton[simp]: "(set {⟨a, b⟩, ⟨c, d⟩})¯⇩∘ = set {⟨b, a⟩, ⟨d, c⟩}"
by (auto simp: vinsert_set_insert_eq)
lemma vconverse_vinsert: "(vinsert ⟨a, b⟩ r)¯⇩∘ = vinsert ⟨b, a⟩ (r¯⇩∘)" by auto
lemma vconverse_vintersection: "(r ∩⇩∘ s)¯⇩∘ = r¯⇩∘ ∩⇩∘ s¯⇩∘" by auto
lemma vconverse_vunion: "(r ∪⇩∘ s)¯⇩∘ = r¯⇩∘ ∪⇩∘ s¯⇩∘" by auto
text‹Connections.›
lemma vconverse_vid_on[simp]: "(vid_on A)¯⇩∘ = vid_on A" by auto
lemma vconverse_vconst_on[simp]: "(vconst_on A c)¯⇩∘ = set {c} ×⇩∘ A" by auto
lemma vconverse_vcomp: "(r ∘⇩∘ s)¯⇩∘ = s¯⇩∘ ∘⇩∘ r¯⇩∘" by auto
lemma vconverse_vtimes: "(A ×⇩∘ B)¯⇩∘ = (B ×⇩∘ A)" by auto
subsubsection‹Left restriction›
definition vlrestriction :: "V ⇒ V"
where "vlrestriction D =
VLambda D (λ⟨r, A⟩. set {⟨a, b⟩ | a b. a ∈⇩∘ A ∧ ⟨a, b⟩ ∈⇩∘ r})"
abbreviation app_vlrestriction :: "V ⇒ V ⇒ V" (infixr ‹↾⇧l⇩∘› 80)
where "r ↾⇧l⇩∘ A ≡ vlrestriction (set {⟨r, A⟩}) ⦇⟨r, A⟩⦈"
lemma app_vlrestriction_def: "r ↾⇧l⇩∘ A = set {⟨a, b⟩ | a b. a ∈⇩∘ A ∧ ⟨a, b⟩ ∈⇩∘ r}"
unfolding vlrestriction_def by simp
lemma vlrestriction_small[simp]: "small {⟨a, b⟩ | a b. a ∈⇩∘ A ∧ ⟨a, b⟩ ∈⇩∘ r}"
by (rule down[of _ r]) auto
text‹Rules.›
lemma vlrestrictionI[intro!]:
assumes "⟨r, A⟩ ∈⇩∘ D"
shows "⟨⟨r, A⟩, r ↾⇧l⇩∘ A⟩ ∈⇩∘ vlrestriction D"
using assms unfolding vlrestriction_def by (simp add: VLambda_iff2)
lemma vlrestrictionD[dest]:
assumes "⟨⟨r, A⟩, s⟩ ∈⇩∘ vlrestriction D"
shows "⟨r, A⟩ ∈⇩∘ D" and "s = r ↾⇧l⇩∘ A"
using assms unfolding vlrestriction_def by auto
lemma vlrestrictionE[elim]:
assumes "x ∈⇩∘ vlrestriction D" and "D ⊆⇩∘ R ×⇩∘ X"
obtains r A where "x = ⟨⟨r, A⟩, r ↾⇧l⇩∘ A⟩" and "r ∈⇩∘ R" and "A ∈⇩∘ X"
using assms unfolding vlrestriction_def by auto
lemma app_vlrestrictionI[intro!]:
assumes "a ∈⇩∘ A" and "⟨a, b⟩ ∈⇩∘ r"
shows "⟨a, b⟩ ∈⇩∘ r ↾⇧l⇩∘ A"
using assms unfolding vlrestriction_def by simp
lemma app_vlrestrictionD[dest]:
assumes "⟨a, b⟩ ∈⇩∘ r ↾⇧l⇩∘ A"
shows "a ∈⇩∘ A" and "⟨a, b⟩ ∈⇩∘ r"
using assms unfolding vlrestriction_def by auto
lemma app_vlrestrictionE[elim]:
assumes "x ∈⇩∘ r ↾⇧l⇩∘ A"
obtains a b where "x = ⟨a, b⟩" and "a ∈⇩∘ A" and "⟨a, b⟩ ∈⇩∘ r"
using assms unfolding vlrestriction_def by auto
text‹Set operations.›
lemma vlrestriction_on_vempty[simp]: "r ↾⇧l⇩∘ 0 = 0"
by (auto intro!: vsubset_antisym)
lemma vlrestriction_vempty[simp]: "0 ↾⇧l⇩∘ A = 0" by auto
lemma vlrestriction_vsingleton_in[simp]:
assumes "a ∈⇩∘ A"
shows "set {⟨a, b⟩} ↾⇧l⇩∘ A = set {⟨a, b⟩}"
using assms by auto
lemma vlrestriction_vsingleton_nin[simp]:
assumes "a ∉⇩∘ A"
shows "set {⟨a, b⟩} ↾⇧l⇩∘ A = 0"
using assms by auto
lemma vlrestriction_mono:
assumes "A ⊆⇩∘ B"
shows "r ↾⇧l⇩∘ A ⊆⇩∘ r ↾⇧l⇩∘ B"
using assms by auto
lemma vlrestriction_vinsert_nin[simp]:
assumes "a ∉⇩∘ A"
shows "(vinsert ⟨a, b⟩ r) ↾⇧l⇩∘ A = r ↾⇧l⇩∘ A"
using assms by auto
lemma vlrestriction_vinsert_in:
assumes "a ∈⇩∘ A"
shows "(vinsert ⟨a, b⟩ r) ↾⇧l⇩∘ A = vinsert ⟨a, b⟩ (r ↾⇧l⇩∘ A)"
using assms by auto
lemma vlrestriction_vintersection: "(r ∩⇩∘ s) ↾⇧l⇩∘ A = r ↾⇧l⇩∘ A ∩⇩∘ s ↾⇧l⇩∘ A" by auto
lemma vlrestriction_vunion: "(r ∪⇩∘ s) ↾⇧l⇩∘ A = r ↾⇧l⇩∘ A ∪⇩∘ s ↾⇧l⇩∘ A" by auto
lemma vlrestriction_vdiff: "(r -⇩∘ s) ↾⇧l⇩∘ A = r ↾⇧l⇩∘ A -⇩∘ s ↾⇧l⇩∘ A" by auto
text‹Connections.›
lemma vlrestriction_vid_on[simp]: "(vid_on A) ↾⇧l⇩∘ B = vid_on (A ∩⇩∘ B)" by auto
lemma vlrestriction_vconst_on: "(vconst_on A c) ↾⇧l⇩∘ B = (vconst_on B c) ↾⇧l⇩∘ A"
by auto
lemma vlrestriction_vconst_on_commute:
assumes "x ∈⇩∘ vconst_on A c ↾⇧l⇩∘ B"
shows "x ∈⇩∘ vconst_on B c ↾⇧l⇩∘ A"
using assms by auto
lemma vlrestriction_vcomp[simp]: "(r ∘⇩∘ s) ↾⇧l⇩∘ A = r ∘⇩∘ (s ↾⇧l⇩∘ A)" by auto
text‹Previous connections.›
lemma vcomp_rel_vid_on[simp]: "r ∘⇩∘ vid_on A = r ↾⇧l⇩∘ A" by auto
lemma vcomp_vconst_on:
"r ∘⇩∘ (vconst_on A c) = (r ↾⇧l⇩∘ set {c}) ∘⇩∘ (vconst_on A c)"
by auto
text‹Special properties.›
lemma vlrestriction_vsubset_vpairs: "r ↾⇧l⇩∘ A ⊆⇩∘ vpairs r"
by (rule vsubsetI) blast
lemma vlrestriction_vsubset_rel: "r ↾⇧l⇩∘ A ⊆⇩∘ r" by auto
lemma vlrestriction_VLambda: "(λa∈⇩∘A. f a) ↾⇧l⇩∘ B = (λa∈⇩∘A ∩⇩∘ B. f a)" by auto
subsubsection‹Right restriction›
definition vrrestriction :: "V ⇒ V"
where "vrrestriction D =
VLambda D (λ⟨r, A⟩. set {⟨a, b⟩ | a b. b ∈⇩∘ A ∧ ⟨a, b⟩ ∈⇩∘ r})"
abbreviation app_vrrestriction :: "V ⇒ V ⇒ V" (infixr ‹↾⇧r⇩∘› 80)
where "r ↾⇧r⇩∘ A ≡ vrrestriction (set {⟨r, A⟩}) ⦇⟨r, A⟩⦈"
lemma app_vrrestriction_def: "r ↾⇧r⇩∘ A = set {⟨a, b⟩ | a b. b ∈⇩∘ A ∧ ⟨a, b⟩ ∈⇩∘ r}"
unfolding vrrestriction_def by simp
lemma vrrestriction_small[simp]: "small {⟨a, b⟩ | a b. b ∈⇩∘ A ∧ ⟨a, b⟩ ∈⇩∘ r}"
by (rule down[of _ r]) auto
text‹Rules.›
lemma vrrestrictionI[intro!]:
assumes "⟨r, A⟩ ∈⇩∘ D"
shows "⟨⟨r, A⟩, r ↾⇧r⇩∘ A⟩ ∈⇩∘ vrrestriction D"
using assms unfolding vrrestriction_def by (simp add: VLambda_iff2)
lemma vrrestrictionD[dest]:
assumes "⟨⟨r, A⟩, s⟩ ∈⇩∘ vrrestriction D"
shows "⟨r, A⟩ ∈⇩∘ D" and "s = r ↾⇧r⇩∘ A"
using assms unfolding vrrestriction_def by auto
lemma vrrestrictionE[elim]:
assumes "x ∈⇩∘ vrrestriction D" and "D ⊆⇩∘ R ×⇩∘ X"
obtains r A where "x = ⟨⟨r, A⟩, r ↾⇧r⇩∘ A⟩" and "r ∈⇩∘ R" and "A ∈⇩∘ X"
using assms unfolding vrrestriction_def by auto
lemma app_vrrestrictionI[intro!]:
assumes "b ∈⇩∘ A" and "⟨a, b⟩ ∈⇩∘ r"
shows "⟨a, b⟩ ∈⇩∘ r ↾⇧r⇩∘ A"
using assms unfolding vrrestriction_def by simp
lemma app_vrrestrictionD[dest]:
assumes "⟨a, b⟩ ∈⇩∘ r ↾⇧r⇩∘ A"
shows "b ∈⇩∘ A" and "⟨a, b⟩ ∈⇩∘ r"
using assms unfolding vrrestriction_def by auto
lemma app_vrrestrictionE[elim]:
assumes "x ∈⇩∘ r ↾⇧r⇩∘ A"
obtains a b where "x = ⟨a, b⟩" and "b ∈⇩∘ A" and "⟨a, b⟩ ∈⇩∘ r"
using assms unfolding vrrestriction_def by auto
text‹Set operations.›
lemma vrrestriction_on_vempty[simp]: "r ↾⇧r⇩∘ 0 = 0"
by (auto intro!: vsubset_antisym)
lemma vrrestriction_vempty[simp]: "0 ↾⇧r⇩∘ A = 0" by auto
lemma vrrestriction_vsingleton_in[simp]:
assumes "b ∈⇩∘ A"
shows "set {⟨a, b⟩} ↾⇧r⇩∘ A = set {⟨a, b⟩}"
using assms by auto
lemma vrrestriction_vsingleton_nin[simp]:
assumes "b ∉⇩∘ A"
shows "set {⟨a, b⟩} ↾⇧r⇩∘ A = 0"
using assms by auto
lemma vrrestriction_mono:
assumes "A ⊆⇩∘ B"
shows "r ↾⇧r⇩∘ A ⊆⇩∘ r ↾⇧r⇩∘ B"
using assms by auto
lemma vrrestriction_vinsert_nin[simp]:
assumes "b ∉⇩∘ A"
shows "(vinsert ⟨a, b⟩ r) ↾⇧r⇩∘ A = r ↾⇧r⇩∘ A"
using assms by auto
lemma vrrestriction_vinsert_in:
assumes "b ∈⇩∘ A"
shows "(vinsert ⟨a, b⟩ r) ↾⇧r⇩∘ A = vinsert ⟨a, b⟩ (r ↾⇧r⇩∘ A)"
using assms by auto
lemma vrrestriction_vintersection: "(r ∩⇩∘ s) ↾⇧r⇩∘ A = r ↾⇧r⇩∘ A ∩⇩∘ s ↾⇧r⇩∘ A" by auto
lemma vrrestriction_vunion: "(r ∪⇩∘ s) ↾⇧r⇩∘ A = r ↾⇧r⇩∘ A ∪⇩∘ s ↾⇧r⇩∘ A" by auto
lemma vrrestriction_vdiff: "(r -⇩∘ s) ↾⇧r⇩∘ A = r ↾⇧r⇩∘ A -⇩∘ s ↾⇧r⇩∘ A" by auto
text‹Connections.›
lemma vrrestriction_vid_on[simp]: "(vid_on A) ↾⇧r⇩∘ B = vid_on (A ∩⇩∘ B)" by auto
lemma vrrestriction_vconst_on:
assumes "c ∈⇩∘ B"
shows "(vconst_on A c) ↾⇧r⇩∘ B = vconst_on A c"
using assms by auto
lemma vrrestriction_vcomp[simp]: "(r ∘⇩∘ s) ↾⇧r⇩∘ A = (r ↾⇧r⇩∘ A) ∘⇩∘ s" by auto
text‹Previous connections.›
lemma vcomp_vid_on_rel[simp]: "vid_on A ∘⇩∘ r = r ↾⇧r⇩∘ A"
by (auto intro!: vsubset_antisym)
lemma vcomp_vconst_on_rel: "(vconst_on A c) ∘⇩∘ r = (vconst_on A c) ∘⇩∘ (r ↾⇧r⇩∘ A)"
by auto
lemma vlrestriction_vconverse: "r¯⇩∘ ↾⇧l⇩∘ A = (r ↾⇧r⇩∘ A)¯⇩∘" by auto
lemma vrrestriction_vconverse: "r¯⇩∘ ↾⇧r⇩∘ A = (r ↾⇧l⇩∘ A)¯⇩∘" by auto
text‹Special properties.›
lemma vrrestriction_vsubset_rel: "r ↾⇧r⇩∘ A ⊆⇩∘ r" by auto
lemma vrrestriction_vsubset_vpairs: "r ↾⇧r⇩∘ A ⊆⇩∘ vpairs r" by auto
subsubsection‹Restriction›
definition vrestriction :: "V ⇒ V"
where "vrestriction D =
VLambda D (λ⟨r, A⟩. set {⟨a, b⟩ | a b. a ∈⇩∘ A ∧ b ∈⇩∘ A ∧ ⟨a, b⟩ ∈⇩∘ r})"
abbreviation app_vrestriction :: "V ⇒ V ⇒ V" (infixr ‹↾⇩∘› 80)
where "r ↾⇩∘ A ≡ vrestriction (set {⟨r, A⟩}) ⦇⟨r, A⟩⦈"
lemma app_vrestriction_def:
"r ↾⇩∘ A = set {⟨a, b⟩ | a b. a ∈⇩∘ A ∧ b ∈⇩∘ A ∧ ⟨a, b⟩ ∈⇩∘ r}"
unfolding vrestriction_def by simp
lemma vrestriction_small[simp]:
"small {⟨a, b⟩ | a b. a ∈⇩∘ A ∧ b ∈⇩∘ A ∧ ⟨a, b⟩ ∈⇩∘ r}"
by (rule down[of _ r]) auto
text‹Rules.›
lemma vrestrictionI[intro!]:
assumes "⟨r, A⟩ ∈⇩∘ D"
shows "⟨⟨r, A⟩, r ↾⇩∘ A⟩ ∈⇩∘ vrestriction D"
using assms unfolding vrestriction_def by (simp add: VLambda_iff2)
lemma vrestrictionD[dest]:
assumes "⟨⟨r, A⟩, s⟩ ∈⇩∘ vrestriction D"
shows "⟨r, A⟩ ∈⇩∘ D" and "s = r ↾⇩∘ A"
using assms unfolding vrestriction_def by auto
lemma vrestrictionE[elim]:
assumes "x ∈⇩∘ vrestriction D" and "D ⊆⇩∘ R ×⇩∘ X"
obtains r A where "x = ⟨⟨r, A⟩, r ↾⇩∘ A⟩" and "r ∈⇩∘ R" and "A ∈⇩∘ X"
using assms unfolding vrestriction_def by auto
lemma app_vrestrictionI[intro!]:
assumes "a ∈⇩∘ A" and "b ∈⇩∘ A" and "⟨a, b⟩ ∈⇩∘ r"
shows "⟨a, b⟩ ∈⇩∘ r ↾⇩∘ A"
using assms unfolding vrestriction_def by simp
lemma app_vrestrictionD[dest]:
assumes "⟨a, b⟩ ∈⇩∘ r ↾⇩∘ A"
shows "a ∈⇩∘ A" and "b ∈⇩∘ A" and "⟨a, b⟩ ∈⇩∘ r"
using assms unfolding vrestriction_def by auto
lemma app_vrestrictionE[elim]:
assumes "x ∈⇩∘ r ↾⇩∘ A"
obtains a b where "x = ⟨a, b⟩" and "a ∈⇩∘ A" and "b ∈⇩∘ A" and "⟨a, b⟩ ∈⇩∘ r"
using assms unfolding vrestriction_def by clarsimp
text‹Set operations.›
lemma vrestriction_on_vempty[simp]: "r ↾⇩∘ 0 = 0"
by (auto intro!: vsubset_antisym)
lemma vrestriction_vempty[simp]: "0 ↾⇩∘ A = 0" by auto
lemma vrestriction_vsingleton_in[simp]:
assumes "a ∈⇩∘ A" and "b ∈⇩∘ A"
shows "set {⟨a, b⟩} ↾⇩∘ A = set {⟨a, b⟩}"
using assms by auto
lemma vrestriction_vsingleton_nin_left[simp]:
assumes "a ∉⇩∘ A"
shows "set {⟨a, b⟩} ↾⇩∘ A = 0"
using assms by auto
lemma vrestriction_vsingleton_nin_right[simp]:
assumes "b ∉⇩∘ A"
shows "set {⟨a, b⟩} ↾⇩∘ A = 0"
using assms by auto
lemma vrestriction_mono:
assumes "A ⊆⇩∘ B"
shows "r ↾⇩∘ A ⊆⇩∘ r ↾⇩∘ B"
using assms by auto
lemma vrestriction_vinsert_nin[simp]:
assumes "a ∉⇩∘ A" and "b ∉⇩∘ A"
shows "(vinsert ⟨a, b⟩ r) ↾⇩∘ A = r ↾⇩∘ A"
using assms by auto
lemma vrestriction_vinsert_in:
assumes "a ∈⇩∘ A" and "b ∈⇩∘ A"
shows "(vinsert ⟨a, b⟩ r) ↾⇩∘ A = vinsert ⟨a, b⟩ (r ↾⇩∘ A)"
using assms by auto
lemma vrestriction_vintersection: "(r ∩⇩∘ s) ↾⇩∘ A = r ↾⇩∘ A ∩⇩∘ s ↾⇩∘ A" by auto
lemma vrestriction_vunion: "(r ∪⇩∘ s) ↾⇩∘ A = r ↾⇩∘ A ∪⇩∘ s ↾⇩∘ A" by auto
lemma vrestriction_vdiff: "(r -⇩∘ s) ↾⇩∘ A = r ↾⇩∘ A -⇩∘ s ↾⇩∘ A" by auto
text‹Connections.›
lemma vrestriction_vid_on[simp]: "(vid_on A) ↾⇩∘ B = vid_on (A ∩⇩∘ B)" by auto
lemma vrestriction_vconst_on_ex:
assumes "c ∈⇩∘ B"
shows "(vconst_on A c) ↾⇩∘ B = vconst_on (A ∩⇩∘ B) c"
using assms by auto
lemma vrestriction_vconst_on_nex:
assumes "c ∉⇩∘ B"
shows "(vconst_on A c) ↾⇩∘ B = 0"
using assms by auto
lemma vrestriction_vcomp[simp]: "(r ∘⇩∘ s) ↾⇩∘ A = (r ↾⇧r⇩∘ A) ∘⇩∘ (s ↾⇧l⇩∘ A)" by auto
lemma vrestriction_vconverse: "r¯⇩∘ ↾⇩∘ A = (r ↾⇩∘ A)¯⇩∘" by auto
text‹Previous connections.›
lemma vrrestriction_vlrestriction[simp]: "(r ↾⇧r⇩∘ A) ↾⇧l⇩∘ A = r ↾⇩∘ A" by auto
lemma vlrestriction_vrrestriction[simp]: "(r ↾⇧l⇩∘ A) ↾⇧r⇩∘ A = r ↾⇩∘ A" by auto
lemma vrestriction_vlrestriction[simp]: "(r ↾⇩∘ A) ↾⇧l⇩∘ A = r ↾⇩∘ A" by auto
lemma vrestriction_vrrestriction[simp]: "(r ↾⇩∘ A) ↾⇧r⇩∘ A = r ↾⇩∘ A" by auto
text‹Special properties.›
lemma vrestriction_vsubset_vpairs: "r ↾⇩∘ A ⊆⇩∘ vpairs r" by auto
lemma vrestriction_vsubset_vtimes: "r ↾⇩∘ A ⊆⇩∘ A ×⇩∘ A" by auto
lemma vrestriction_vsubset_rel: "r ↾⇩∘ A ⊆⇩∘ r" by auto
subsection‹Properties›
subsubsection‹Domain›
definition vdomain :: "V ⇒ V"
where "vdomain D = (λr∈⇩∘D. set {a. ∃b. ⟨a, b⟩ ∈⇩∘ r})"
abbreviation app_vdomain :: "V ⇒ V" (‹𝒟⇩∘›)
where "𝒟⇩∘ r ≡ vdomain (set {r}) ⦇r⦈"
lemma app_vdomain_def: "𝒟⇩∘ r = set {a. ∃b. ⟨a, b⟩ ∈⇩∘ r}"
unfolding vdomain_def by simp
lemma vdomain_small[simp]: "small {a. ∃b. ⟨a, b⟩ ∈⇩∘ r}"
proof-
have ss: "{a. ∃b. ⟨a, b⟩ ∈⇩∘ r} ⊆ vfst ` elts r" using image_iff by fastforce
have small: "small (vfst ` elts r)" by (rule replacement) simp
show ?thesis by (rule smaller_than_small, rule small, rule ss)
qed
text‹Rules.›
lemma vdomainI[intro!]:
assumes "r ∈⇩∘ A"
shows "⟨r, 𝒟⇩∘ r⟩ ∈⇩∘ vdomain A"
using assms unfolding vdomain_def by auto
lemma vdomainD[dest]:
assumes "⟨r, s⟩ ∈⇩∘ vdomain A"
shows "r ∈⇩∘ A" and "s = 𝒟⇩∘ r"
using assms unfolding vdomain_def by auto
lemma vdomainE[elim]:
assumes "x ∈⇩∘ vdomain A"
obtains r where "x = ⟨r, 𝒟⇩∘ r⟩" and "r ∈⇩∘ A"
using assms unfolding vdomain_def by auto
lemma app_vdomainI[intro]:
assumes "⟨a, b⟩ ∈⇩∘ r"
shows "a ∈⇩∘ 𝒟⇩∘ r"
using assms unfolding vdomain_def by auto
lemma app_vdomainD[dest]:
assumes "a ∈⇩∘ 𝒟⇩∘ r"
shows "∃b. ⟨a, b⟩ ∈⇩∘ r"
using assms unfolding vdomain_def by auto
lemma app_vdomainE[elim]:
assumes "a ∈⇩∘ 𝒟⇩∘ r"
obtains b where "⟨a, b⟩ ∈⇩∘ r"
using assms unfolding vdomain_def by clarsimp
lemma vdomain_iff: "a ∈⇩∘ 𝒟⇩∘ r ⟷ (∃y. ⟨a, y⟩ ∈⇩∘ r)" by auto
text‹Set operations.›
lemma vdomain_vempty[simp]: "𝒟⇩∘ 0 = 0" by (auto intro!: vsubset_antisym)
lemma vdomain_vsingleton[simp]: "𝒟⇩∘ (set {⟨a, b⟩}) = set {a}" by auto
lemma vdomain_vdoubleton[simp]: "𝒟⇩∘ (set {⟨a, b⟩, ⟨c, d⟩}) = set {a, c}"
by (auto simp: vinsert_set_insert_eq)
lemma vdomain_mono:
assumes "r ⊆⇩∘ s"
shows "𝒟⇩∘ r ⊆⇩∘ 𝒟⇩∘ s"
using assms by blast
lemma vdomain_vinsert[simp]: "𝒟⇩∘ (vinsert ⟨a, b⟩ r) = vinsert a (𝒟⇩∘ r)"
by (auto intro!: vsubset_antisym)
lemma vdomain_vunion: "𝒟⇩∘ (A ∪⇩∘ B) = 𝒟⇩∘ A ∪⇩∘ 𝒟⇩∘ B"
by (auto intro!: vsubset_antisym)
lemma vdomain_vintersection_vsubset: "𝒟⇩∘ (A ∩⇩∘ B) ⊆⇩∘ 𝒟⇩∘ A ∩⇩∘ 𝒟⇩∘ B" by auto
lemma vdomain_vdiff_vsubset: "𝒟⇩∘ A -⇩∘ 𝒟⇩∘ B ⊆⇩∘ 𝒟⇩∘ (A -⇩∘ B)" by auto
text‹Connections.›
lemma vdomain_vid_on[simp]: "𝒟⇩∘ (vid_on A) = A"
by (auto intro!: vsubset_antisym)
lemma vdomain_vconst_on[simp]: "𝒟⇩∘ (vconst_on A c) = A"
by (auto intro!: vsubset_antisym)
lemma vdomain_VLambda[simp]: "𝒟⇩∘ (λa∈⇩∘A. f a) = A"
by (auto intro!: vsubset_antisym)
lemma vdomain_vlrestriction: "𝒟⇩∘ (r ↾⇧l⇩∘ A) = 𝒟⇩∘ r ∩⇩∘ A" by auto
text‹Special properties.›
lemma vdomain_vsubset_vtimes:
assumes "vpairs r ⊆⇩∘ x ×⇩∘ y"
shows "𝒟⇩∘ r ⊆⇩∘ x"
using assms by auto
subsubsection‹Range›
definition vrange :: "V ⇒ V"
where "vrange D = (λr∈⇩∘D. set {b. ∃a. ⟨a, b⟩ ∈⇩∘ r})"
abbreviation app_vrange :: "V ⇒ V" (‹ℛ⇩∘›)
where "ℛ⇩∘ r ≡ vrange (set {r}) ⦇r⦈"
lemma app_vrange_def: "ℛ⇩∘ r = set {b. ∃a. ⟨a, b⟩ ∈⇩∘ r}"
unfolding vrange_def by simp
lemma vrange_small[simp]: "small {b. ∃a. ⟨a, b⟩ ∈⇩∘ r}"
proof-
have ss: "{b. ∃a. ⟨a, b⟩ ∈⇩∘ r} ⊆ vsnd ` elts r" using image_iff by fastforce
have small: "small (vsnd ` elts r)" by (rule replacement) simp
show ?thesis by (rule smaller_than_small, rule small, rule ss)
qed
text‹Rules.›
lemma vrangeI[intro]:
assumes "r ∈⇩∘ A"
shows "⟨r, ℛ⇩∘ r⟩ ∈⇩∘ vrange A"
using assms unfolding vrange_def by auto
lemma vrangeD[dest]:
assumes "⟨r, s⟩ ∈⇩∘ vrange A"
shows "r ∈⇩∘ A" and "s = ℛ⇩∘ r"
using assms unfolding vrange_def by auto
lemma vrangeE[elim]:
assumes "x ∈⇩∘ vrange A"
obtains r where "x = ⟨r, ℛ⇩∘ r⟩" and "r ∈⇩∘ A"
using assms unfolding vrange_def by auto
lemma app_vrangeI[intro]:
assumes "⟨a, b⟩ ∈⇩∘ r"
shows "b ∈⇩∘ ℛ⇩∘ r"
using assms unfolding vrange_def by auto
lemma app_vrangeD[dest]:
assumes "b ∈⇩∘ ℛ⇩∘ r"
shows "∃a. ⟨a, b⟩ ∈⇩∘ r"
using assms unfolding vrange_def by simp
lemma app_vrangeE[elim]:
assumes "b ∈⇩∘ ℛ⇩∘ r"
obtains a where "⟨a, b⟩ ∈⇩∘ r"
using assms unfolding vrange_def by clarsimp
lemma vrange_iff: "b ∈⇩∘ ℛ⇩∘ r ⟷ (∃a. ⟨a, b⟩ ∈⇩∘ r)" by auto
text‹Set operations.›
lemma vrange_vempty[simp]: "ℛ⇩∘ 0 = 0" by (auto intro!: vsubset_antisym)
lemma vrange_vsingleton[simp]: "ℛ⇩∘ (set {⟨a, b⟩}) = set {b}" by auto
lemma vrange_vdoubleton[simp]: "ℛ⇩∘ (set {⟨a, b⟩, ⟨c, d⟩}) = set {b, d}"
by (auto simp: vinsert_set_insert_eq)
lemma vrange_mono:
assumes "r ⊆⇩∘ s"
shows "ℛ⇩∘ r ⊆⇩∘ ℛ⇩∘ s"
using assms by force
lemma vrange_vinsert[simp]: "ℛ⇩∘ (vinsert ⟨a, b⟩ r) = vinsert b (ℛ⇩∘ r)"
by (auto intro!: vsubset_antisym)
lemma vrange_vunion: "ℛ⇩∘ (r ∪⇩∘ s) = ℛ⇩∘ r ∪⇩∘ ℛ⇩∘ s"
by (auto intro!: vsubset_antisym)
lemma vrange_vintersection_vsubset: "ℛ⇩∘ (r ∩⇩∘ s) ⊆⇩∘ ℛ⇩∘ r ∩⇩∘ ℛ⇩∘ s" by auto
lemma vrange_vdiff_vsubset: "ℛ⇩∘ r -⇩∘ ℛ⇩∘ s ⊆⇩∘ ℛ⇩∘ (r -⇩∘ s)" by auto
text‹Connections.›
lemma vrange_vid_on[simp]: "ℛ⇩∘ (vid_on A) = A" by (auto intro!: vsubset_antisym)
lemma vrange_vconst_on_vempty[simp]: "ℛ⇩∘ (vconst_on 0 c) = 0" by auto
lemma vrange_vconst_on_ne[simp]:
assumes "A ≠ 0"
shows "ℛ⇩∘ (vconst_on A c) = set {c}"
using assms by (auto intro!: vsubset_antisym)
lemma vrange_VLambda: "ℛ⇩∘ (λa∈⇩∘A. f a) = set (f ` elts A)"
by (intro vsubset_antisym vsubsetI) auto
lemma vrange_vrrestriction: "ℛ⇩∘ (r ↾⇧r⇩∘ A) = ℛ⇩∘ r ∩⇩∘ A" by auto
text‹Previous connections›
lemma vdomain_vconverse[simp]: "𝒟⇩∘ (r¯⇩∘) = ℛ⇩∘ r"
by (auto intro!: vsubset_antisym)
lemma vrange_vconverse[simp]: "ℛ⇩∘ (r¯⇩∘) = 𝒟⇩∘ r"
by (auto intro!: vsubset_antisym)
text‹Special properties.›
lemma vrange_iff_vdomain: "b ∈⇩∘ ℛ⇩∘ r ⟷ (∃a∈⇩∘𝒟⇩∘ r. ⟨a, b⟩ ∈⇩∘ r)" by auto
lemma vrange_vsubset_vtimes:
assumes "vpairs r ⊆⇩∘ x ×⇩∘ y"
shows "ℛ⇩∘ r ⊆⇩∘ y"
using assms by auto
lemma vrange_VLambda_vsubset:
assumes "⋀x. x ∈⇩∘ A ⟹ f x ∈⇩∘ B"
shows "ℛ⇩∘ (VLambda A f) ⊆⇩∘ B"
using assms by auto
lemma vpairs_vsubset_vdomain_vrange[simp]: "vpairs r ⊆⇩∘ 𝒟⇩∘ r ×⇩∘ ℛ⇩∘ r"
by (rule vsubsetI) auto
lemma vrange_vsubset:
assumes "⋀x y. ⟨x, y⟩ ∈⇩∘ r ⟹ y ∈⇩∘ A"
shows "ℛ⇩∘ r ⊆⇩∘ A"
using assms by auto
subsubsection‹Field›
definition vfield :: "V ⇒ V"
where "vfield D = (λr∈⇩∘D. 𝒟⇩∘ r ∪⇩∘ ℛ⇩∘ r)"
abbreviation app_vfield :: "V ⇒ V" (‹ℱ⇩∘›)
where "ℱ⇩∘ r ≡ vfield (set {r}) ⦇r⦈"
lemma app_vfield_def: "ℱ⇩∘ r = 𝒟⇩∘ r ∪⇩∘ ℛ⇩∘ r" unfolding vfield_def by simp
text‹Rules.›
lemma vfieldI[intro!]:
assumes "r ∈⇩∘ A"
shows "⟨r, ℱ⇩∘ r⟩ ∈⇩∘ vfield A"
using assms unfolding vfield_def by auto
lemma vfieldD[dest]:
assumes "⟨r, s⟩ ∈⇩∘ vfield A"
shows "r ∈⇩∘ A" and "s = ℱ⇩∘ r"
using assms unfolding vfield_def by auto
lemma vfieldE[elim]:
assumes "x ∈⇩∘ vfield A"
obtains r where "x = ⟨r, ℱ⇩∘ r⟩" and "r ∈⇩∘ A"
using assms unfolding vfield_def by auto
lemma app_vfieldI1[intro]:
assumes "a ∈⇩∘ 𝒟⇩∘ r ∪⇩∘ ℛ⇩∘ r"
shows "a ∈⇩∘ ℱ⇩∘ r"
using assms unfolding vfield_def by simp
lemma app_vfieldI2[intro]:
assumes "⟨a, b⟩ ∈⇩∘ r"
shows "a ∈⇩∘ ℱ⇩∘ r"
using assms by auto
lemma app_vfieldI3[intro]:
assumes "⟨a, b⟩ ∈⇩∘ r"
shows "b ∈⇩∘ ℱ⇩∘ r"
using assms by auto
lemma app_vfieldD[dest]:
assumes "a ∈⇩∘ ℱ⇩∘ r"
shows "a ∈⇩∘ 𝒟⇩∘ r ∪⇩∘ ℛ⇩∘ r"
using assms unfolding vfield_def by simp
lemma app_vfieldE[elim]:
assumes "a ∈⇩∘ ℱ⇩∘ r" and "a ∈⇩∘ 𝒟⇩∘ r ∪⇩∘ ℛ⇩∘ r ⟹ P"
shows P
using assms by auto
lemma app_vfield_vpairE[elim]:
assumes "a ∈⇩∘ ℱ⇩∘ r"
obtains b where "⟨a, b⟩ ∈⇩∘ r ∨ ⟨b, a⟩ ∈⇩∘ r "
using assms unfolding app_vfield_def by blast
lemma vfield_iff: "a ∈⇩∘ ℱ⇩∘ r ⟷ (∃b. ⟨a, b⟩ ∈⇩∘ r ∨ ⟨b, a⟩ ∈⇩∘ r)" by auto
text‹Set operations.›
lemma vfield_vempty[simp]: "ℱ⇩∘ 0 = 0" by (auto intro!: vsubset_antisym)
lemma vfield_vsingleton[simp]: "ℱ⇩∘ (set {⟨a, b⟩}) = set {a, b}"
by (simp add: app_vfield_def vinsert_set_insert_eq)
lemma vfield_vdoubleton[simp]: "ℱ⇩∘ (set {⟨a, b⟩, ⟨c, d⟩}) = set {a, b, c, d}"
by (auto simp: vinsert_set_insert_eq)
lemma vfield_mono:
assumes "r ⊆⇩∘ s"
shows "ℱ⇩∘ r ⊆⇩∘ ℱ⇩∘ s"
using assms by fastforce
lemma vfield_vinsert[simp]: "ℱ⇩∘ (vinsert ⟨a, b⟩ r) = set {a, b} ∪⇩∘ ℱ⇩∘ r"
by (auto intro!: vsubset_antisym)
lemma vfield_vunion[simp]: "ℱ⇩∘ (r ∪⇩∘ s) = ℱ⇩∘ r ∪⇩∘ ℱ⇩∘ s"
by (auto intro!: vsubset_antisym)
text‹Connections.›
lemma vid_on_vfield[simp]: "ℱ⇩∘ (vid_on A) = A" by (auto intro!: vsubset_antisym)
lemma vconst_on_vfield_ne[intro, simp]:
assumes "A ≠ 0"
shows "ℱ⇩∘ (vconst_on A c) = vinsert c A"
using assms by (auto intro!: vsubset_antisym)
lemma vconst_on_vfield_vempty[simp]: "ℱ⇩∘ (vconst_on 0 c) = 0" by auto
lemma vfield_vconverse[simp]: "ℱ⇩∘ (r¯⇩∘) = ℱ⇩∘ r"
by (auto intro!: vsubset_antisym)
subsubsection‹Image›
definition vimage :: "V ⇒ V"
where "vimage D = VLambda D (λ⟨r, A⟩. ℛ⇩∘ (r ↾⇧l⇩∘ A))"
abbreviation app_vimage :: "V ⇒ V ⇒ V" (infixr ‹`⇩∘› 90)
where "r `⇩∘ A ≡ vimage (set {⟨r, A⟩}) ⦇⟨r, A⟩⦈"
lemma app_vimage_def: "r `⇩∘ A = ℛ⇩∘ (r ↾⇧l⇩∘ A)" unfolding vimage_def by simp
lemma vimage_small[simp]: "small {b. ∃a∈⇩∘A. ⟨a, b⟩ ∈⇩∘ r}"
proof-
have ss: "{b. ∃a∈⇩∘A. ⟨a, b⟩ ∈⇩∘ r} ⊆ vsnd ` elts r"
using image_iff by fastforce
have small: "small (vsnd ` elts r)" by (rule replacement) simp
show ?thesis by (rule smaller_than_small, rule small, rule ss)
qed
lemma app_vimage_set_def: "r `⇩∘ A = set {b. ∃a∈⇩∘A. ⟨a, b⟩ ∈⇩∘ r}"
unfolding vimage_def vrange_def by auto
text‹Rules.›
lemma vimageI[intro!]:
assumes "⟨r, A⟩ ∈⇩∘ D"
shows "⟨⟨r, A⟩, r `⇩∘ A⟩ ∈⇩∘ vimage D"
using assms unfolding vimage_def by (simp add: VLambda_iff2)
lemma vimageD[dest]:
assumes "⟨⟨r, A⟩, s⟩ ∈⇩∘ vimage D"
shows "⟨r, A⟩ ∈⇩∘ D" and "s = r `⇩∘ A"
using assms unfolding vimage_def by auto
lemma vimageE[elim]:
assumes "x ∈⇩∘ vimage (R ×⇩∘ X)"
obtains r A where "x = ⟨⟨r, A⟩, r `⇩∘ A⟩" and "r ∈⇩∘ R" and "A ∈⇩∘ X"
using assms unfolding vimage_def by auto
lemma app_vimageI1:
assumes "x ∈⇩∘ ℛ⇩∘ (r ↾⇧l⇩∘ A)"
shows "x ∈⇩∘ r `⇩∘ A"
using assms unfolding vimage_def by simp
lemma app_vimageI2[intro]:
assumes "⟨a, b⟩ ∈⇩∘ r" and "a ∈⇩∘ A"
shows "b ∈⇩∘ r `⇩∘ A"
using assms app_vimageI1 by auto
lemma app_vimageD[dest]:
assumes "x ∈⇩∘ r `⇩∘ A"
shows "x ∈⇩∘ ℛ⇩∘ (r ↾⇧l⇩∘ A)"
using assms unfolding vimage_def by simp
lemma app_vimageE[elim]:
assumes "b ∈⇩∘ r `⇩∘ A"
obtains a where "⟨a, b⟩ ∈⇩∘ r" and "a ∈⇩∘ A"
using assms unfolding vimage_def by auto
lemma app_vimage_iff: "b ∈⇩∘ r `⇩∘ A ⟷ (∃a∈⇩∘A. ⟨a, b⟩ ∈⇩∘ r)" by auto
text‹Set operations.›
lemma vimage_vempty[simp]: "0 `⇩∘ A = 0" by (auto intro!: vsubset_antisym)
lemma vimage_of_vempty[simp]: "r `⇩∘ 0 = 0" by (auto intro!: vsubset_antisym)
lemma vimage_vsingleton: "r `⇩∘ set {a} = set {b. ⟨a, b⟩ ∈⇩∘ r}"
proof-
have "{b. ⟨a, b⟩ ∈⇩∘ r} ⊆ {b. ∃a. ⟨a, b⟩ ∈⇩∘ r}" by auto
then have [simp]: "small {b. ⟨a, b⟩ ∈⇩∘ r}"
by (rule smaller_than_small[OF vrange_small[of r]])
show ?thesis using app_vimage_set_def by auto
qed
lemma vimage_vsingleton_in[intro, simp]:
assumes "a ∈⇩∘ A"
shows "set {⟨a, b⟩} `⇩∘ A = set {b}"
using assms by auto
lemma vimage_vsingleton_nin[intro, simp]:
assumes "a ∉⇩∘ A"
shows "set {⟨a, b⟩} `⇩∘ A = 0"
using assms by auto
lemma vimage_vsingleton_vinsert[simp]: "set {⟨a, b⟩} `⇩∘ vinsert a A = set {b}"
by auto
lemma vimage_mono:
assumes "r' ⊆⇩∘ r" and "A' ⊆⇩∘ A"
shows "(r' `⇩∘ A') ⊆⇩∘ (r `⇩∘ A)"
using assms by fastforce
lemma vimage_vinsert: "r `⇩∘ (vinsert a A) = r `⇩∘ set {a} ∪⇩∘ r `⇩∘ A"
by (auto intro!: vsubset_antisym)
lemma vimage_vunion_left: "(r ∪⇩∘ s) `⇩∘ A = r `⇩∘ A ∪⇩∘ s `⇩∘ A"
by (auto intro!: vsubset_antisym)
lemma vimage_vunion_right: "r `⇩∘ (A ∪⇩∘ B) = r `⇩∘ A ∪⇩∘ r `⇩∘ B"
by (auto intro!: vsubset_antisym)
lemma vimage_vintersection: "r `⇩∘ (A ∩⇩∘ B) ⊆⇩∘ r `⇩∘ A ∩⇩∘ r `⇩∘ B" by auto
lemma vimage_vdiff: "r `⇩∘ A -⇩∘ r `⇩∘ B ⊆⇩∘ r `⇩∘ (A -⇩∘ B)" by auto
text‹Previous set operations.›
lemma VPow_vinsert:
"VPow (vinsert a A) = VPow A ∪⇩∘ ((λx∈⇩∘VPow A. vinsert a x) `⇩∘ VPow A)"
proof(intro vsubset_antisym vsubsetI)
fix x assume "x ∈⇩∘ VPow (vinsert a A)"
then have "x ⊆⇩∘ vinsert a A" by simp
then consider "x ⊆⇩∘ A" | "a ∈⇩∘ x" by auto
then show "x ∈⇩∘ VPow A ∪⇩∘ (λx∈⇩∘VPow A. vinsert a x) `⇩∘ VPow A"
proof cases
case 1 then show ?thesis by simp
next
case 2
define x' where "x' = x -⇩∘ set {a}"
with 2 have "x = vinsert a x'" and "a ∉⇩∘ x'" by auto
with ‹x ⊆⇩∘ vinsert a A› show ?thesis
unfolding vimage_def
by (fastforce simp: vsubset_vinsert vlrestriction_VLambda)
qed
qed (elim vunionE, auto)
text‹Special properties.›
lemma vimage_vsingleton_iff[iff]: "b ∈⇩∘ r `⇩∘ set {a} ⟷ ⟨a, b⟩ ∈⇩∘ r" by auto
lemma vimage_is_vempty[iff]: "r `⇩∘ A = 0 ⟷ vdisjnt (𝒟⇩∘ r) A" by fastforce
lemma vcomp_vimage_vtimes_right:
assumes "r `⇩∘ Y = Z"
shows "r ∘⇩∘ (X ×⇩∘ Y) = X ×⇩∘ Z"
proof(intro vsubset_antisym vsubsetI)
fix x assume x: "x ∈⇩∘ r ∘⇩∘ (X ×⇩∘ Y)"
then obtain a c where x_def: "x = ⟨a, c⟩" and "a ∈⇩∘ X" and "c ∈⇩∘ ℛ⇩∘ r" by auto
with x obtain b where "⟨a, b⟩ ∈⇩∘ X ×⇩∘ Y" and "⟨b, c⟩ ∈⇩∘ r" by clarsimp
then show "x ∈⇩∘ X ×⇩∘ Z" unfolding x_def using assms by auto
next
fix x assume "x ∈⇩∘ X ×⇩∘ Z"
then obtain a c where x_def: "x = ⟨a, c⟩" and "a ∈⇩∘ X" and "c ∈⇩∘ Z" by auto
then show "x ∈⇩∘ r ∘⇩∘ X ×⇩∘ Y"
using assms unfolding x_def by (meson VSigmaI app_vimageE vcompI)
qed
text‹Connections.›
lemma vid_on_vimage[simp]: "vid_on A `⇩∘ B = A ∩⇩∘ B"
by (auto intro!: vsubset_antisym)
lemma vimage_vconst_on_ne[simp]:
assumes "B ∩⇩∘ A ≠ 0"
shows "vconst_on A c `⇩∘ B = set {c}"
using assms by auto
lemma vimage_vconst_on_vempty[simp]:
assumes "vdisjnt A B"
shows "vconst_on A c `⇩∘ B = 0"
using assms by auto
lemma vimage_vconst_on_vsubset_vconst: "vconst_on A c `⇩∘ B ⊆⇩∘ set {c}" by auto
lemma vimage_VLambda_vrange: "(λa∈⇩∘A. f a) `⇩∘ B = ℛ⇩∘ (λa∈⇩∘A ∩⇩∘ B. f a)"
unfolding vimage_def by (simp add: vlrestriction_VLambda)
lemma vimage_VLambda_vrange_rep: "(λa∈⇩∘A. f a) `⇩∘ A = ℛ⇩∘ (λa∈⇩∘A. f a)"
by (simp add: vimage_VLambda_vrange)
lemma vcomp_vimage: "(r ∘⇩∘ s) `⇩∘ A = r `⇩∘ (s `⇩∘ A)"
by (auto intro!: vsubset_antisym)
lemma vimage_vlrestriction[simp]: "(r ↾⇧l⇩∘ A) `⇩∘ B = r `⇩∘ (A ∩⇩∘ B)"
by (auto intro!: vsubset_antisym)
lemma vimage_vrrestriction[simp]: "(r ↾⇧r⇩∘ A) `⇩∘ B = A ∩⇩∘ r `⇩∘ B" by auto
lemma vimage_vrestriction[simp]: "(r ↾⇩∘ A) `⇩∘ B = A ∩⇩∘ (r `⇩∘ (A ∩⇩∘ B))" by auto
lemma vimage_vdomain: "r `⇩∘ 𝒟⇩∘ r = ℛ⇩∘ r" by (auto intro!: vsubset_antisym)
lemma vimage_eq_imp_vcomp:
assumes "r `⇩∘ A = s `⇩∘ B"
shows "(t ∘⇩∘ r) `⇩∘ A = (t ∘⇩∘ s) `⇩∘ B"
using assms by (metis vcomp_vimage)
text‹Previous connections.›
lemma vcomp_rel_vconst: "r ∘⇩∘ (vconst_on A c) = A ×⇩∘ (r `⇩∘ set {c})"
by auto
lemma vcomp_VLambda:
"(λb∈⇩∘((λa∈⇩∘A. g a) `⇩∘ A). f b) ∘⇩∘ (λa∈⇩∘A. g a) = (λa∈⇩∘A. (f ∘ g) a)"
using VLambda_iff1 by (auto intro!: vsubset_antisym)+
text‹Further special properties.›
lemma vimage_vsubset:
assumes "r ⊆⇩∘ A ×⇩∘ B"
shows "r `⇩∘ C ⊆⇩∘ B"
using assms by auto
lemma vimage_vdomain_vsubset: "r `⇩∘ A ⊆⇩∘ r `⇩∘ 𝒟⇩∘ r" by auto
lemma vdomain_vsubset_VUnion2: "𝒟⇩∘ r ⊆⇩∘ ⋃⇩∘(⋃⇩∘r)"
proof(intro vsubsetI)
fix x assume "x ∈⇩∘ 𝒟⇩∘ r"
then obtain y where "⟨x, y⟩ ∈⇩∘ r" by auto
then have "set {set {x}, set {x, y}} ∈⇩∘ r" unfolding vpair_def by auto
with insert_commute have xy_Ur: "set {x, y} ∈⇩∘ ⋃⇩∘r"
unfolding VUnion_iff by auto
define Ur where "Ur = ⋃⇩∘r"
from xy_Ur show "x ∈⇩∘ ⋃⇩∘(⋃⇩∘r)"
unfolding Ur_def[symmetric] by (auto dest: VUnionI)
qed
lemma vrange_vsubset_VUnion2: "ℛ⇩∘ r ⊆⇩∘ ⋃⇩∘(⋃⇩∘r)"
proof(intro vsubsetI)
fix y assume "y ∈⇩∘ ℛ⇩∘ r"
then obtain x where "⟨x, y⟩ ∈⇩∘ r" by auto
then have "set {set {x}, set {x, y}} ∈⇩∘ r" unfolding vpair_def by auto
with insert_commute have xy_Ur: "set {x, y} ∈⇩∘ ⋃⇩∘r"
unfolding VUnion_iff by auto
define Ur where "Ur = ⋃⇩∘r"
from xy_Ur show "y ∈⇩∘ ⋃⇩∘(⋃⇩∘r)"
unfolding Ur_def[symmetric] by (auto dest: VUnionI)
qed
lemma vfield_vsubset_VUnion2: "ℱ⇩∘ r ⊆⇩∘ ⋃⇩∘(⋃⇩∘r)"
using vdomain_vsubset_VUnion2 vrange_vsubset_VUnion2
by (auto simp: app_vfield_def)
subsubsection‹Inverse image›
definition invimage :: "V ⇒ V"
where "invimage D = VLambda D (λ⟨r, A⟩. r¯⇩∘ `⇩∘ A)"
abbreviation app_invimage :: "V ⇒ V ⇒ V" (infixr ‹-`⇩∘› 90)
where "r -`⇩∘ A ≡ invimage (set {⟨r, A⟩}) ⦇⟨r, A⟩⦈"
lemma app_invimage_def: "r -`⇩∘ A = r¯⇩∘ `⇩∘ A" unfolding invimage_def by simp
lemma invimage_small[simp]: "small {a. ∃b∈⇩∘A. ⟨a, b⟩ ∈⇩∘ r}"
proof-
have ss: "{a. ∃b∈⇩∘A. ⟨a, b⟩ ∈⇩∘ r} ⊆ vfst ` elts r"
using image_iff by fastforce
have small: "small (vfst ` elts r)" by (rule replacement) simp
show ?thesis by (rule smaller_than_small, rule small, rule ss)
qed
text‹Rules.›
lemma invimageI[intro!]:
assumes "⟨r, A⟩ ∈⇩∘ D"
shows "⟨⟨r, A⟩, r -`⇩∘ A⟩ ∈⇩∘ invimage D"
using assms unfolding invimage_def by (simp add: VLambda_iff2)
lemma invimageD[dest]:
assumes "⟨⟨r, A⟩, s⟩ ∈⇩∘ invimage D"
shows "⟨r, A⟩ ∈⇩∘ D" and "s = r -`⇩∘ A"
using assms unfolding invimage_def by auto
lemma invimageE[elim]:
assumes "x ∈⇩∘ invimage D" and "D ⊆⇩∘ R ×⇩∘ X"
obtains r A where "x = ⟨⟨r, A⟩, r -`⇩∘ A⟩" and "r ∈⇩∘ R" and "A ∈⇩∘ X"
using assms unfolding invimage_def by auto
lemma app_invimageI[intro]:
assumes "⟨a, b⟩ ∈⇩∘ r" and "b ∈⇩∘ A"
shows "a ∈⇩∘ r -`⇩∘ A"
using assms invimage_def by auto
lemma app_invimageD[dest]:
assumes "a ∈⇩∘ r -`⇩∘ A"
shows "a ∈⇩∘ 𝒟⇩∘ (r ↾⇧r⇩∘ A)"
using assms using invimage_def by auto
lemma app_invimageE[elim]:
assumes "a ∈⇩∘ r -`⇩∘ A"
obtains b where "⟨a, b⟩ ∈⇩∘ r" and "b ∈⇩∘ A"
using assms unfolding invimage_def by auto
lemma app_invimageI1:
assumes "a ∈⇩∘ 𝒟⇩∘ (r ↾⇧r⇩∘ A)"
shows "a ∈⇩∘ r -`⇩∘ A"
using assms unfolding vimage_def
by (simp add: invimage_def app_vimageI1 vlrestriction_vconverse)
lemma app_invimageD1:
assumes "a ∈⇩∘ r -`⇩∘ A"
shows "a ∈⇩∘ 𝒟⇩∘ (r ↾⇧r⇩∘ A)"
using assms by fastforce
lemma app_invimageE1:
assumes "a ∈⇩∘ r -`⇩∘ A " and "a ∈⇩∘ 𝒟⇩∘ (r ↾⇧r⇩∘ A) ⟹ P"
shows P
using assms unfolding invimage_def by auto
lemma app_invimageI2:
assumes "a ∈⇩∘ r¯⇩∘ `⇩∘ A"
shows "a ∈⇩∘ r -`⇩∘ A"
using assms unfolding invimage_def by simp
lemma app_invimageD2:
assumes "a ∈⇩∘ r -`⇩∘ A"
shows "a ∈⇩∘ r¯⇩∘ `⇩∘ A"
using assms unfolding invimage_def by simp
lemma app_invimageE2:
assumes "a ∈⇩∘ r -`⇩∘ A" and "a ∈⇩∘ r¯⇩∘ `⇩∘ A ⟹ P"
shows P
unfolding vimage_def by (simp add: assms app_invimageD2)
lemma invimage_iff: "a ∈⇩∘ r -`⇩∘ A ⟷ (∃b∈⇩∘A. ⟨a, b⟩ ∈⇩∘ r)" by auto
lemma invimage_iff1: "a ∈⇩∘ r -`⇩∘ A ⟷ a ∈⇩∘ 𝒟⇩∘ (r ↾⇧r⇩∘ A)" by auto
lemma invimage_iff2: "a ∈⇩∘ r -`⇩∘ A ⟷ a ∈⇩∘ r¯⇩∘ `⇩∘ A" by auto
text‹Set operations.›
lemma invimage_vempty[simp]: "0 -`⇩∘ A = 0" by (auto intro!: vsubset_antisym)
lemma invimage_of_vempty[simp]: "r -`⇩∘ 0 = 0" by (auto intro!: vsubset_antisym)
lemma invimage_vsingleton_in[intro, simp]:
assumes "b ∈⇩∘ A"
shows "set {⟨a, b⟩} -`⇩∘ A = set {a}"
using assms by auto
lemma invimage_vsingleton_nin[intro, simp]:
assumes "b ∉⇩∘ A"
shows "set {⟨a, b⟩} -`⇩∘ A = 0"
using assms by auto
lemma invimage_vsingleton_vinsert[intro, simp]:
"set {⟨a, b⟩} -`⇩∘ vinsert b A = set {a}"
by auto
lemma invimage_mono:
assumes "r' ⊆⇩∘ r" and "A' ⊆⇩∘ A"
shows "(r' -`⇩∘ A') ⊆⇩∘ (r -`⇩∘ A)"
using assms by fastforce
lemma invimage_vinsert: "r -`⇩∘ (vinsert a A) = r -`⇩∘ set {a} ∪⇩∘ r -`⇩∘ A"
by (auto intro!: vsubset_antisym)
lemma invimage_vunion_left: "(r ∪⇩∘ s) -`⇩∘ A = r -`⇩∘ A ∪⇩∘ s -`⇩∘ A"
by (auto intro!: vsubset_antisym)
lemma invimage_vunion_right: "r -`⇩∘ (A ∪⇩∘ B) = r -`⇩∘ A ∪⇩∘ r -`⇩∘ B"
by (auto intro!: vsubset_antisym)
lemma invimage_vintersection: "r -`⇩∘ (A ∩⇩∘ B) ⊆⇩∘ r -`⇩∘ A ∩⇩∘ r -`⇩∘ B" by auto
lemma invimage_vdiff: "r -`⇩∘ A -⇩∘ r -`⇩∘ B ⊆⇩∘ r -`⇩∘ (A -⇩∘ B)" by auto
text‹Special properties.›
lemma invimage_set_def: "r -`⇩∘ A = set {a. ∃b∈⇩∘A. ⟨a, b⟩ ∈⇩∘ r}" by fastforce
lemma invimage_eq_vdomain_vrestriction: "r -`⇩∘ A = 𝒟⇩∘ (r ↾⇧r⇩∘ A)" by fastforce
lemma invimage_vrange[simp]: "r -`⇩∘ ℛ⇩∘ r = 𝒟⇩∘ r"
unfolding invimage_def by (auto intro!: vsubset_antisym)
lemma invimage_vrange_vsubset[simp]:
assumes "ℛ⇩∘ r ⊆⇩∘ B"
shows "r -`⇩∘ B = 𝒟⇩∘ r"
using assms unfolding app_invimage_def by (blast intro!: vsubset_antisym)
text‹Connections.›
lemma invimage_vid_on[simp]: "vid_on A -`⇩∘ B = A ∩⇩∘ B"
by (auto intro!: vsubset_antisym)
lemma invimage_vconst_on_vsubset_vdomain[simp]: "vconst_on A c -`⇩∘ B ⊆⇩∘ A"
unfolding invimage_def by auto
lemma invimage_vconst_on_ne[simp]:
assumes "c ∈⇩∘ B"
shows "vconst_on A c -`⇩∘ B = A"
by (simp add: assms invimage_eq_vdomain_vrestriction vrrestriction_vconst_on)
lemma invimage_vconst_on_vempty[simp]:
assumes "c ∉⇩∘ B"
shows "vconst_on A c -`⇩∘ B = 0"
using assms by auto
lemma invimage_vcomp: "(r ∘⇩∘ s) -`⇩∘ x = s -`⇩∘ (r -`⇩∘ x) "
by (simp add: invimage_def vconverse_vcomp vcomp_vimage)
lemma invimage_vconverse[simp]: "r¯⇩∘ -`⇩∘ A = r `⇩∘ A"
by (auto intro!: vsubset_antisym)
lemma invimage_vlrestriction[simp]: "(r ↾⇧l⇩∘ A) -`⇩∘ B = A ∩⇩∘ r -`⇩∘ B" by auto
lemma invimage_vrrestriction[simp]: "(r ↾⇧r⇩∘ A) -`⇩∘ B = (r -`⇩∘ (A ∩⇩∘ B))"
by (auto intro!: vsubset_antisym)
lemma invimage_vrestriction[simp]: "(r ↾⇩∘ A) -`⇩∘ B = A ∩⇩∘ (r -`⇩∘ (A ∩⇩∘ B))"
by blast
text‹Previous connections.›
lemma vcomp_vconst_on_rel_vtimes: "vconst_on A c ∘⇩∘ r = (r -`⇩∘ A) ×⇩∘ set {c}"
proof(intro vsubset_antisym vsubsetI)
fix x assume "x ∈⇩∘ r -`⇩∘ A ×⇩∘ set {c}"
then obtain a where x_def: "x = ⟨a, c⟩" and "a ∈⇩∘ r -`⇩∘ A" by auto
then obtain b where ab: "⟨a, b⟩ ∈⇩∘ r" and "b ∈⇩∘ A" using invimage_iff by auto
with ‹b ∈⇩∘ A› show "x ∈⇩∘ vconst_on A c ∘⇩∘ r" unfolding x_def by auto
qed auto
lemma vdomain_vcomp[simp]: "𝒟⇩∘ (r ∘⇩∘ s) = s -`⇩∘ 𝒟⇩∘ r" by blast
lemma vrange_vcomp[simp]: "ℛ⇩∘ (r ∘⇩∘ s) = r `⇩∘ ℛ⇩∘ s" by blast
lemma vdomain_vcomp_vsubset:
assumes "ℛ⇩∘ s ⊆⇩∘ 𝒟⇩∘ r"
shows "𝒟⇩∘ (r ∘⇩∘ s) = 𝒟⇩∘ s"
using assms by simp
subsection‹Classification of relations›
subsubsection‹Binary relation›
locale vbrelation =
fixes r :: V
assumes vbrelation: "vpairs r = r"
text‹Rules.›
lemma vpairs_eqI[intro!]:
assumes "⋀x. x ∈⇩∘ r ⟹ ∃a b. x = ⟨a, b⟩"
shows "vpairs r = r"
using assms by auto
lemma vpairs_eqD[dest]:
assumes "vpairs r = r"
shows "⋀x. x ∈⇩∘ r ⟹ ∃a b. x = ⟨a, b⟩"
using assms by auto
lemma vpairs_eqE[elim!]:
assumes "vpairs r = r" and "(⋀x. x ∈⇩∘ r ⟹ ∃a b. x = ⟨a, b⟩) ⟹ P"
shows P
using assms by auto
lemmas vbrelationI[intro!] = vbrelation.intro
lemmas vbrelationD[dest!] = vbrelation.vbrelation
lemma vbrelationE[elim!]:
assumes "vbrelation r" and "(vpairs r = r) ⟹ P"
shows P
using assms unfolding vbrelation_def by auto
lemma vbrelationE1[elim]:
assumes "vbrelation r" and "x ∈⇩∘ r"
obtains a b where "x = ⟨a, b⟩"
using assms by auto
lemma vbrelationD1[dest]:
assumes "vbrelation r" and "x ∈⇩∘ r"
shows "∃a b. x = ⟨a, b⟩"
using assms by auto
lemma (in vbrelation) vbrelation_vinE:
assumes "x ∈⇩∘ r"
obtains a b where "x = ⟨a, b⟩" and "a ∈⇩∘ 𝒟⇩∘ r" and "b ∈⇩∘ ℛ⇩∘ r"
using assms vbrelation_axioms by blast
text‹Set operations.›
lemma vbrelation_vsubset:
assumes "vbrelation s" and "r ⊆⇩∘ s"
shows "vbrelation r"
using assms by auto
lemma vbrelation_vinsert[simp]: "vbrelation (vinsert ⟨a, b⟩ r) ⟷ vbrelation r"
by auto
lemma (in vbrelation) vbrelation_vinsertI[intro, simp]:
"vbrelation (vinsert ⟨a, b⟩ r)"
using vbrelation_axioms by auto
lemma vbrelation_vinsertD[dest]:
assumes "vbrelation (vinsert ⟨a, b⟩ r)"
shows "vbrelation r"
using assms by auto
lemma vbrelation_vunion: "vbrelation (r ∪⇩∘ s) ⟷ vbrelation r ∧ vbrelation s"
by auto
lemma vbrelation_vunionI:
assumes "vbrelation r" and "vbrelation s"
shows "vbrelation (r ∪⇩∘ s)"
using assms by auto
lemma vbrelation_vunionD[dest]:
assumes "vbrelation (r ∪⇩∘ s)"
shows "vbrelation r" and "vbrelation s"
using assms by auto
lemma (in vbrelation) vbrelation_vintersectionI: "vbrelation (r ∩⇩∘ s)"
using vbrelation_axioms by auto
lemma (in vbrelation) vbrelation_vdiffI: "vbrelation (r -⇩∘ s)"
using vbrelation_axioms by auto
text‹Connections.›
lemma vbrelation_vempty: "vbrelation 0" by auto
lemma vbrelation_vsingleton: "vbrelation (set {⟨a, b⟩})" by auto
lemma vbrelation_vdoubleton: "vbrelation (set {⟨a, b⟩, ⟨c, d⟩})" by auto
lemma vbrelation_vid_on[simp]: "vbrelation (vid_on A)" by auto
lemma vbrelation_vconst_on[simp]: "vbrelation (vconst_on A c)" by auto
lemma vbrelation_VLambda[simp]: "vbrelation (VLambda A f)"
unfolding VLambda_def by (intro vbrelationI) auto
global_interpretation rel_VLambda: vbrelation ‹VLambda U f›
by (rule vbrelation_VLambda)
lemma vbrelation_vcomp:
assumes "vbrelation r" and "vbrelation s"
shows "vbrelation (r ∘⇩∘ s)"
using assms by auto
lemma (in vbrelation) vbrelation_vconverse: "vbrelation (r¯⇩∘)"
using vbrelation_axioms by clarsimp
lemma vbrelation_vlrestriction[intro, simp]: "vbrelation (r ↾⇧l⇩∘ A)" by auto
lemma vbrelation_vrrestriction[intro, simp]: "vbrelation (r ↾⇧r⇩∘ A)" by auto
lemma vbrelation_vrestriction[intro, simp]: "vbrelation (r ↾⇩∘ A)" by auto
text‹Previous connections.›
lemma (in vbrelation) vconverse_vconverse[simp]: "(r¯⇩∘)¯⇩∘ = r"
using vbrelation_axioms by auto
lemma vconverse_mono[simp]:
assumes "vbrelation r" and "vbrelation s"
shows "r¯⇩∘ ⊆⇩∘ s¯⇩∘ ⟷ r ⊆⇩∘ s"
using assms by (force intro: vconverse_vunion)+
lemma vconverse_inject[simp]:
assumes "vbrelation r" and "vbrelation s"
shows "r¯⇩∘ = s¯⇩∘ ⟷ r = s"
using assms by fast
lemma (in vbrelation) vconverse_vsubset_swap_2:
assumes "r¯⇩∘ ⊆⇩∘ s"
shows "r ⊆⇩∘ s¯⇩∘"
using assms vbrelation_axioms by auto
lemma (in vbrelation) vlrestriction_vdomain[simp]: "r ↾⇧l⇩∘ 𝒟⇩∘ r = r"
using vbrelation_axioms by (elim vbrelationE) auto
lemma (in vbrelation) vrrestriction_vrange[simp]: "r ↾⇧r⇩∘ ℛ⇩∘ r = r"
using vbrelation_axioms by (elim vbrelationE) auto
text‹Special properties.›
lemma brel_vsubset_vtimes:
"vbrelation r ⟷ r ⊆⇩∘ set (vfst ` elts r) ×⇩∘ set (vsnd ` elts r)"
by force
lemma vsubset_vtimes_vbrelation:
assumes "r ⊆⇩∘ A ×⇩∘ B"
shows "vbrelation r"
using assms by auto
lemma (in vbrelation) vbrelation_vintersection_vdomain:
assumes "vdisjnt (𝒟⇩∘ r) (𝒟⇩∘ s)"
shows "vdisjnt r s"
proof(intro vsubset_antisym vsubsetI)
fix x assume "x ∈⇩∘ r ∩⇩∘ s"
then obtain a b where "⟨a, b⟩ ∈⇩∘ r ∩⇩∘ s"
by (metis vbrelationE1 vbrelation_vintersectionI)
with assms show "x ∈⇩∘ 0" by auto
qed simp
lemma (in vbrelation) vbrelation_vintersection_vrange:
assumes "vdisjnt (ℛ⇩∘ r) (ℛ⇩∘ s)"
shows "vdisjnt r s"
proof(intro vsubset_antisym vsubsetI)
fix x assume "x ∈⇩∘ r ∩⇩∘ s"
then obtain a b where "⟨a, b⟩ ∈⇩∘ r ∩⇩∘ s"
by (metis vbrelationE1 vbrelation_vintersectionI)
with assms show "x ∈⇩∘ 0" by auto
qed simp
lemma (in vbrelation) vbrelation_vintersection_vfield:
assumes "vdisjnt (vfield r) (vfield s)"
shows "vdisjnt r s"
proof(intro vsubset_antisym vsubsetI)
fix x assume "x ∈⇩∘ r ∩⇩∘ s"
then obtain a b where "⟨a, b⟩ ∈⇩∘ r ∩⇩∘ s"
by (metis vbrelationE1 vbrelation_vintersectionI)
with assms show "x ∈⇩∘ 0" by auto
qed auto
lemma (in vbrelation) vdomain_vrange_vtimes: "r ⊆⇩∘ 𝒟⇩∘ r ×⇩∘ ℛ⇩∘ r"
using vbrelation by auto
lemma (in vbrelation) vbrelation_vsubset_vtimes:
assumes "𝒟⇩∘ r ⊆⇩∘ A" and "ℛ⇩∘ r ⊆⇩∘ B"
shows "r ⊆⇩∘ A ×⇩∘ B"
proof(intro vsubsetI)
fix x assume prems: "x ∈⇩∘ r"
with vbrelation obtain a b where x_def: "x = ⟨a, b⟩" by auto
from prems have a: "a ∈⇩∘ 𝒟⇩∘ r" and b: "b ∈⇩∘ ℛ⇩∘ r" unfolding x_def by auto
with assms have "a ∈⇩∘ A" and "b ∈⇩∘ B" by auto
then show "x ∈⇩∘ A ×⇩∘ B" unfolding x_def by simp
qed
lemma (in vbrelation) vlrestriction_vsubset_vrange[intro, simp]:
assumes "𝒟⇩∘ r ⊆⇩∘ A"
shows "r ↾⇧l⇩∘ A = r"
proof(intro vsubset_antisym)
show "r ⊆⇩∘ r ↾⇧l⇩∘ A"
by (rule vlrestriction_mono[OF assms, of r, unfolded vlrestriction_vdomain])
qed auto
lemma (in vbrelation) vrrestriction_vsubset_vrange[intro, simp]:
assumes "ℛ⇩∘ r ⊆⇩∘ B"
shows "r ↾⇧r⇩∘ B = r"
proof(intro vsubset_antisym)
show "r ⊆⇩∘ r ↾⇧r⇩∘ B"
by (rule vrrestriction_mono[OF assms, of r, unfolded vrrestriction_vrange])
qed auto
lemma (in vbrelation) vbrelation_vcomp_vid_on_left[simp]:
assumes "ℛ⇩∘ r ⊆⇩∘ A"
shows "vid_on A ∘⇩∘ r = r"
using assms by auto
lemma (in vbrelation) vbrelation_vcomp_vid_on_right[simp]:
assumes "𝒟⇩∘ r ⊆⇩∘ A"
shows "r ∘⇩∘ vid_on A = r"
using assms by auto
text‹Alternative forms of existing results.›
lemmas [intro, simp] = vbrelation.vconverse_vconverse
and [intro, simp] = vbrelation.vlrestriction_vsubset_vrange
and [intro, simp] = vbrelation.vrrestriction_vsubset_vrange
subsubsection‹Simple single-valued relation›
locale vsv = vbrelation r for r +
assumes vsv: "⟦ ⟨a, b⟩ ∈⇩∘ r; ⟨a, c⟩ ∈⇩∘ r ⟧ ⟹ b = c"
text‹Rules.›
lemmas (in vsv) [intro] = vsv_axioms
mk_ide rf vsv_def[unfolded vsv_axioms_def]
|intro vsvI[intro]|
|dest vsvD[dest]|
|elim vsvE[elim]|
text‹Set operations.›
lemma (in vsv) vsv_vinsert[simp]:
assumes "a ∉⇩∘ 𝒟⇩∘ r"
shows "vsv (vinsert ⟨a, b⟩ r)"
using assms vsv_axioms by blast
lemma vsv_vinsertD:
assumes "vsv (vinsert x r)"
shows "vsv r"
using assms by (intro vsvI) auto
lemma vsv_vunion[intro, simp]:
assumes "vsv r" and "vsv s" and "vdisjnt (𝒟⇩∘ r) (𝒟⇩∘ s)"
shows "vsv (r ∪⇩∘ s)"
proof
from assms have F: "⟦ ⟨a, b⟩ ∈⇩∘ r; ⟨a, c⟩ ∈⇩∘ s ⟧ ⟹ False" for a b c
using elts_0 by blast
fix a b c assume "⟨a, b⟩ ∈⇩∘ r ∪⇩∘ s" and "⟨a, c⟩ ∈⇩∘ r ∪⇩∘ s"
then consider
"⟨a, b⟩ ∈⇩∘ r ∧ ⟨a, c⟩ ∈⇩∘ r"
| "⟨a, b⟩ ∈⇩∘ r ∧ ⟨a, c⟩ ∈⇩∘ s"
| "⟨a, b⟩ ∈⇩∘ s ∧ ⟨a, c⟩ ∈⇩∘ r"
| "⟨a, b⟩ ∈⇩∘ s ∧ ⟨a, c⟩ ∈⇩∘ s"
by blast
then show "b = c" using assms by cases auto
qed (use assms in auto)
lemma (in vsv) vsv_vintersection[intro, simp]: "vsv (r ∩⇩∘ s)"
using vsv_axioms by blast
lemma (in vsv) vsv_vdiff[intro, simp]: "vsv (r -⇩∘ s)" using vsv_axioms by blast
text‹Connections.›
lemma vsv_vempty[simp]: "vsv 0" by auto
lemma vsv_vsingleton[simp]: "vsv (set {⟨a, b⟩})" by auto
global_interpretation rel_vsingleton: vsv ‹set {⟨a, b⟩}›
by (rule vsv_vsingleton)
lemma vsv_vdoubleton:
assumes "a ≠ c"
shows "vsv (set {⟨a, b⟩, ⟨c, d⟩})"
using assms by (auto simp: vinsert_set_insert_eq)
lemma vsv_vid_on[simp]: "vsv (vid_on A)" by auto
lemma vsv_vconst_on[simp]: "vsv (vconst_on A c)" by auto
lemma vsv_VLambda[simp]: "vsv (λa∈⇩∘A. f a)" by auto
global_interpretation rel_VLambda: vsv ‹(λa∈⇩∘A. f a)›
unfolding VLambda_def by (intro vsvI) auto
lemma vsv_vcomp:
assumes "vsv r" and "vsv s"
shows "vsv (r ∘⇩∘ s)"
using assms
by (intro vsvI; elim vsvE) (simp add: vbrelation_vcomp, metis vcompD)
lemma (in vsv) vsv_vlrestriction[intro, simp]: "vsv (r ↾⇧l⇩∘ A)"
using vsv_axioms by blast
lemma (in vsv) vsv_vrrestriction[intro, simp]: "vsv (r ↾⇧r⇩∘ A)"
using vsv_axioms by blast
lemma (in vsv) vsv_vrestriction[intro, simp]: "vsv (r ↾⇩∘ A)"
using vsv_axioms by blast
text‹Special properties.›
lemma small_vsv[simp]: "small {f. vsv f ∧ 𝒟⇩∘ f = A ∧ ℛ⇩∘ f ⊆⇩∘ B}"
proof-
have "small {f. f ⊆⇩∘ A ×⇩∘ B}" by (auto simp: small_iff)
moreover have "{f. vsv f ∧ 𝒟⇩∘ f = A ∧ ℛ⇩∘ f ⊆⇩∘ B} ⊆ {f. f ⊆⇩∘ A ×⇩∘ B}"
by auto
ultimately show "small {f. vsv f ∧ 𝒟⇩∘ f = A ∧ ℛ⇩∘ f ⊆⇩∘ B}"
by (auto simp: smaller_than_small)
qed
context vsv
begin
lemma vsv_ex1:
assumes "a ∈⇩∘ 𝒟⇩∘ r"
shows "∃!b. ⟨a, b⟩ ∈⇩∘ r"
using vsv_axioms assms by auto
lemma vsv_ex1_app1:
assumes "a ∈⇩∘ 𝒟⇩∘ r"
shows "b = r⦇a⦈ ⟷ ⟨a, b⟩ ∈⇩∘ r"
proof
assume b_def: "b = r⦇a⦈" show "⟨a, b⟩ ∈⇩∘ r"
unfolding app_def b_def by (rule theI') (rule vsv_ex1[OF assms])
next
assume [simp]: "⟨a, b⟩ ∈⇩∘ r"
from assms vsv_axioms vsvD have THE_b: "(THE y. ⟨a, y⟩ ∈⇩∘ r) = b" by auto
show "b = r⦇a⦈" unfolding app_def THE_b[symmetric] by (rule refl)
qed
lemma vsv_ex1_app2[iff]:
assumes "a ∈⇩∘ 𝒟⇩∘ r"
shows "r⦇a⦈ = b ⟷ ⟨a, b⟩ ∈⇩∘ r"
using vsv_ex1_app1[OF assms] by auto
lemma vsv_appI[intro, simp]:
assumes "⟨a, b⟩ ∈⇩∘ r"
shows "r⦇a⦈ = b"
using assms by (subgoal_tac ‹a ∈⇩∘ 𝒟⇩∘ r›) auto
lemma vsv_appE:
assumes "r⦇a⦈ = b" and "a ∈⇩∘ 𝒟⇩∘ r" and "⟨a, b⟩ ∈⇩∘ r ⟹ P"
shows P
using assms vsv_ex1_app1 by blast
lemma vdomain_vrange_is_vempty: "𝒟⇩∘ r = 0 ⟷ ℛ⇩∘ r = 0" by fastforce
lemma vsv_vrange_vempty:
assumes "ℛ⇩∘ r = 0"
shows "r = 0"
using assms vdomain_vrange_is_vempty vlrestriction_vdomain by auto
lemma vsv_vdomain_vempty_vrange_vempty:
assumes "𝒟⇩∘ r ≠ 0"
shows "ℛ⇩∘ r ≠ 0"
using assms by fastforce
lemma vsv_vdomain_vsingleton_vrange_vsingleton:
assumes "𝒟⇩∘ r = set {a}"
obtains b where "ℛ⇩∘ r = set {b}"
proof-
from assms obtain b where ab: "⟨a, b⟩ ∈⇩∘ r" by auto
then have "⟨a, c⟩ ∈⇩∘ r ⟹ c = b" for c by (auto simp: vsv)
moreover with assms have "⟨b, c⟩ ∈⇩∘ r ⟹ c = a" for c by force
ultimately have "⟨c, d⟩ ∈⇩∘ r ⟹ d = b" for c d
by (metis app_vdomainI assms vsingletonD)
with ab have "ℛ⇩∘ r = set {b}" by blast
with that show ?thesis by simp
qed
lemma vsv_vsubset_vimageE:
assumes "B ⊆⇩∘ r `⇩∘ A"
obtains C where "C ⊆⇩∘ A" and "B = r `⇩∘ C"
proof-
define C where C_def: "C = (r¯⇩∘ `⇩∘ B) ∩⇩∘ A"
then have "C ⊆⇩∘ A" by auto
moreover have "B = r `⇩∘ C"
unfolding C_def
proof(intro vsubset_antisym vsubsetI)
fix b assume "b ∈⇩∘ B"
with assms obtain a where "a ∈⇩∘ A" and "⟨a, b⟩ ∈⇩∘ r"
using app_vimageE vsubsetD by metis
then have "a ∈⇩∘ r¯⇩∘ `⇩∘ B ∩⇩∘ A" by (auto simp: ‹b ∈⇩∘ B›)
then show "b ∈⇩∘ r `⇩∘ (r¯⇩∘ `⇩∘ B ∩⇩∘ A)" by (auto intro: ‹⟨a, b⟩ ∈⇩∘ r›)
qed (use vsv_axioms in auto)
ultimately show ?thesis using that by auto
qed
lemma vsv_vimage_eqI[intro]:
assumes "a ∈⇩∘ 𝒟⇩∘ r" and "r⦇a⦈ = b" and "a ∈⇩∘ A"
shows "b ∈⇩∘ r `⇩∘ A"
using assms(2)[unfolded vsv_ex1_app2[OF assms(1)]] assms(3) by auto
lemma vsv_vimageI1:
assumes "a ∈⇩∘ 𝒟⇩∘ r" and "a ∈⇩∘ A"
shows "r⦇a⦈ ∈⇩∘ r `⇩∘ A"
using assms by (simp add: vsv_vimage_eqI)
lemma vsv_vimageI2:
assumes "a ∈⇩∘ 𝒟⇩∘ r"
shows "r⦇a⦈ ∈⇩∘ ℛ⇩∘ r"
using assms by (blast dest: vsv_ex1_app1)
lemma vsv_vimageI2':
assumes "b = r⦇a⦈" and "a ∈⇩∘ 𝒟⇩∘ r"
shows "b ∈⇩∘ ℛ⇩∘ r"
using assms by (blast dest: vsv_ex1_app1)
lemma vsv_value:
assumes "a ∈⇩∘ 𝒟⇩∘ r"
obtains b where "r⦇a⦈ = b" and "b ∈⇩∘ ℛ⇩∘ r"
using assms by (blast dest: vsv_ex1_app1)
lemma vsv_vimageE:
assumes "b ∈⇩∘ r `⇩∘ A"
obtains x where "r⦇x⦈ = b" and "x ∈⇩∘ A"
using assms vsv_axioms vsv_ex1_app2 by blast
lemma vsv_vimage_iff: "b ∈⇩∘ r `⇩∘ A ⟷ (∃a. a ∈⇩∘ A ∧ a ∈⇩∘ 𝒟⇩∘ r ∧ r⦇a⦈ = b)"
using vsv_axioms by (blast intro: vsv_ex1_app1[THEN iffD1])+
lemma vsv_vimage_vsingleton:
assumes "a ∈⇩∘ 𝒟⇩∘ r"
shows "r `⇩∘ set {a} = set {r⦇a⦈}"
using assms by force
lemma vsv_vimage_vsubsetI:
assumes "⋀a. ⟦ a ∈⇩∘ A; a ∈⇩∘ 𝒟⇩∘ r ⟧ ⟹ r⦇a⦈ ∈⇩∘ B"
shows "r `⇩∘ A ⊆⇩∘ B"
using assms by (metis vsv_vimage_iff vsubsetI)
lemma vsv_image_vsubset_iff:
"r `⇩∘ A ⊆⇩∘ B ⟷ (∀a∈⇩∘A. a ∈⇩∘ 𝒟⇩∘ r ⟶ r⦇a⦈ ∈⇩∘ B)"
by (auto simp: vsv_vimage_iff)
lemma vsv_vimage_vinsert:
assumes "a ∈⇩∘ 𝒟⇩∘ r"
shows "r `⇩∘ vinsert a A = vinsert (r⦇a⦈) (r `⇩∘ A)"
using assms vsv_vimage_iff by (intro vsubset_antisym vsubsetI) auto
lemma vsv_vinsert_vimage[intro, simp]:
assumes "a ∈⇩∘ 𝒟⇩∘ r" and "a ∈⇩∘ A"
shows "vinsert (r⦇a⦈) (r `⇩∘ A) = r `⇩∘ A"
using assms by auto
lemma vsv_is_VLambda[simp]: "(λx∈⇩∘𝒟⇩∘ r. r⦇x⦈) = r"
using vbrelation
by (auto simp: app_vdomainI VLambda_iff2 intro!: vsubset_antisym)
lemma vsv_is_VLambda_on_vlrestriction[intro, simp]:
assumes "A ⊆⇩∘ 𝒟⇩∘ r"
shows "(λx∈⇩∘A. r⦇x⦈) = r ↾⇧l⇩∘ A"
using assms by (force simp: VLambda_iff2)+
lemma pairwise_vimageI:
assumes "⋀x y.
⟦ x ∈⇩∘ 𝒟⇩∘ r; y ∈⇩∘ 𝒟⇩∘ r; x ≠ y; r⦇x⦈ ≠ r⦇y⦈ ⟧ ⟹ P (r⦇x⦈) (r⦇y⦈)"
shows "vpairwise P (ℛ⇩∘ r)"
by (intro vpairwiseI) (metis assms app_vdomainI app_vrangeE vsv_appI)
lemma vsv_vrange_vsubset:
assumes "⋀x. x ∈⇩∘ 𝒟⇩∘ r ⟹ r⦇x⦈ ∈⇩∘ A"
shows "ℛ⇩∘ r ⊆⇩∘ A"
using assms by fastforce
lemma vsv_vlrestriction_vinsert:
assumes "a ∈⇩∘ 𝒟⇩∘ r"
shows "r ↾⇧l⇩∘ vinsert a A = vinsert ⟨a, r⦇a⦈⟩ (r ↾⇧l⇩∘ A)"
using assms by (auto intro!: vsubset_antisym)
end
lemma vsv_eqI:
assumes "vsv r"
and "vsv s"
and "𝒟⇩∘ r = 𝒟⇩∘ s"
and "⋀a. a ∈⇩∘ 𝒟⇩∘ r ⟹ r⦇a⦈ = s⦇a⦈"
shows "r = s"
proof(intro vsubset_antisym vsubsetI)
interpret r: vsv r by (rule assms(1))
interpret s: vsv s by (rule assms(2))
fix x assume "x ∈⇩∘ r"
then obtain a b where x_def[simp]: "x = ⟨a, b⟩" and "a ∈⇩∘ 𝒟⇩∘ r"
by (elim r.vbrelation_vinE)
with ‹x ∈⇩∘ r› have "r⦇a⦈ = b" by simp
with assms ‹a ∈⇩∘ 𝒟⇩∘ r› show "x ∈⇩∘ s" by fastforce
next
interpret r: vsv r by (rule assms(1))
interpret s: vsv s by (rule assms(2))
fix x assume "x ∈⇩∘ s"
with assms(2) obtain a b where x_def[simp]: "x = ⟨a, b⟩" and "a ∈⇩∘ 𝒟⇩∘ s"
by (elim vsvE) blast
with assms ‹x ∈⇩∘ s› have "s⦇a⦈ = b" by blast
with assms ‹a ∈⇩∘ 𝒟⇩∘ s› show "x ∈⇩∘ r" by fastforce
qed
lemma (in vsv) vsv_VLambda_cong:
assumes "⋀a. a ∈⇩∘ 𝒟⇩∘ r ⟹ r⦇a⦈ = f a"
shows "(λa∈⇩∘𝒟⇩∘ r. f a) = r"
proof(rule vsv_eqI[symmetric])
show "𝒟⇩∘ r = 𝒟⇩∘ (VLambda (𝒟⇩∘ r) f)" by simp
fix a assume a: "a ∈⇩∘ 𝒟⇩∘ r"
then show "r⦇a⦈ = VLambda (𝒟⇩∘ r) f ⦇a⦈" using assms(1)[OF a] by auto
qed auto
lemma Axiom_of_Choice:
obtains f where "⋀x. x ∈⇩∘ A ⟹ x ≠ 0 ⟹ f⦇x⦈ ∈⇩∘ x" and "vsv f"
proof-
obtain f where f: "x ∈⇩∘ A ⟹ x ≠ 0 ⟹ f⦇x⦈ ∈⇩∘ x" for x
by (metis beta vemptyE)
define f' where "f' = (λx∈⇩∘A. f⦇x⦈)"
have "x ∈⇩∘ A ⟹ x ≠ 0 ⟹ f'⦇x⦈ ∈⇩∘ x" for x
unfolding f'_def using f by simp
moreover have "vsv f'" unfolding f'_def by simp
ultimately show ?thesis using that by auto
qed
lemma VLambda_eqI:
assumes "X = Y" and "⋀x. x ∈⇩∘ X ⟹ f x = g x"
shows "(λx∈⇩∘X. f x) = (λy∈⇩∘Y. g y)"
proof(rule vsv_eqI, unfold vdomain_VLambda; (intro assms(1) vsv_VLambda)?)
fix x assume "x ∈⇩∘ X"
with assms show "VLambda X f⦇x⦈ = VLambda Y g⦇x⦈" by simp
qed
lemma VLambda_vsingleton_def: "(λi∈⇩∘set {j}. f i) = (λi∈⇩∘set {j}. f j)" by auto
text‹Alternative forms of the available results.›
lemmas [iff] = vsv.vsv_ex1_app2
and [intro, simp] = vsv.vsv_appI
and [elim] = vsv.vsv_appE
and [intro] = vsv.vsv_vimage_eqI
and [simp] = vsv.vsv_vinsert_vimage
and [intro] = vsv.vsv_is_VLambda_on_vlrestriction
and [simp] = vsv.vsv_is_VLambda
and [intro, simp] = vsv.vsv_vintersection
and [intro, simp] = vsv.vsv_vdiff
and [intro, simp] = vsv.vsv_vlrestriction
and [intro, simp] = vsv.vsv_vrrestriction
and [intro, simp] = vsv.vsv_vrestriction
subsubsection‹Specialization of existing properties to single-valued relations.›
text‹Identity relation.›
lemma vid_on_eq_atI[intro, simp]:
assumes "a = b" and "a ∈⇩∘ A"
shows "vid_on A ⦇a⦈ = b"
using assms by auto
lemma vid_on_atI[intro, simp]:
assumes "a ∈⇩∘ A"
shows "vid_on A ⦇a⦈ = a"
using assms by auto
lemma vid_on_at_iff[intro, simp]:
assumes "a ∈⇩∘ A"
shows "vid_on A ⦇a⦈ = b ⟷ a = b"
using assms by auto
text‹Constant function.›
lemma vconst_on_atI[simp]:
assumes "a ∈⇩∘ A"
shows "vconst_on A c ⦇a⦈ = c"
using assms by auto
text‹Composition.›
lemma vcomp_atI[intro, simp]:
assumes "vsv r"
and "vsv s"
and "a ∈⇩∘ 𝒟⇩∘ r"
and "b ∈⇩∘ 𝒟⇩∘ s"
and "s⦇b⦈ = c"
and "r⦇a⦈ = b"
shows "(s ∘⇩∘ r)⦇a⦈ = c"
using assms by (auto simp: app_invimageI intro!: vsv_vcomp)
lemma vcomp_atD[dest]:
assumes "(s ∘⇩∘ r)⦇a⦈ = c"
and "vsv r"
and "vsv s"
and "a ∈⇩∘ 𝒟⇩∘ r"
and "r⦇a⦈ ∈⇩∘ 𝒟⇩∘ s"
shows "∃b. s⦇b⦈ = c ∧ r⦇a⦈ = b"
using assms by (metis vcomp_atI)
lemma vcomp_atE1:
assumes "(s ∘⇩∘ r)⦇a⦈ = c"
and "vsv r"
and "vsv s"
and "a ∈⇩∘ 𝒟⇩∘ r"
and "r⦇a⦈ ∈⇩∘ 𝒟⇩∘ s"
and "∃b. s⦇b⦈ = c ∧ r⦇a⦈ = b ⟹ P"
shows P
using assms assms vcomp_atD by blast
lemma vcomp_atE[elim]:
assumes "(s ∘⇩∘ r)⦇a⦈ = c"
and "vsv r"
and "vsv s"
and "a ∈⇩∘ 𝒟⇩∘ r"
and "r⦇a⦈ ∈⇩∘ 𝒟⇩∘ s"
obtains b where "r⦇a⦈ = b" and "s⦇b⦈ = c"
using assms that by (force elim!: vcomp_atE1)
lemma vsv_vcomp_at[simp]:
assumes "vsv r" and "vsv s" and "a ∈⇩∘ 𝒟⇩∘ r" and "r⦇a⦈ ∈⇩∘ 𝒟⇩∘ s"
shows "(s ∘⇩∘ r)⦇a⦈ = s⦇r⦇a⦈⦈"
using assms by auto
context vsv
begin
text‹Converse relation.›
lemma vconverse_atI[intro]:
assumes "a ∈⇩∘ 𝒟⇩∘ r" and "r⦇a⦈ = b"
shows "⟨b, a⟩ ∈⇩∘ r¯⇩∘"
using assms by auto
lemma vconverse_atD[dest]:
assumes "⟨b, a⟩ ∈⇩∘ r¯⇩∘"
shows "r⦇a⦈ = b"
using assms by auto
lemma vconverse_atE[elim]:
assumes "⟨b, a⟩ ∈⇩∘ r¯⇩∘" and "r⦇a⦈ = b ⟹ P"
shows P
using assms by auto
lemma vconverse_iff:
assumes "a ∈⇩∘ 𝒟⇩∘ r"
shows "⟨b, a⟩ ∈⇩∘ r¯⇩∘ ⟷ r⦇a⦈ = b"
using assms by auto
text‹Left restriction.›
interpretation vlrestriction: vsv ‹r ↾⇧l⇩∘ A› by (rule vsv_vlrestriction)
lemma vlrestriction_atI[intro, simp]:
assumes "a ∈⇩∘ 𝒟⇩∘ r" and "a ∈⇩∘ A" and "r⦇a⦈ = b"
shows "(r ↾⇧l⇩∘ A)⦇a⦈ = b"
using assms by (auto simp: vdomain_vlrestriction)
lemma vlrestriction_atD[dest]:
assumes "(r ↾⇧l⇩∘ A)⦇a⦈ = b" and "a ∈⇩∘ 𝒟⇩∘ r" and "a ∈⇩∘ A"
shows "r⦇a⦈ = b"
using assms by (auto simp: vdomain_vlrestriction)
lemma vlrestriction_atE1[elim]:
assumes "(r ↾⇧l⇩∘ A)⦇a⦈ = b"
and "a ∈⇩∘ 𝒟⇩∘ r"
and "a ∈⇩∘ A"
and "r⦇a⦈ = b ⟹ P"
shows P
using assms vlrestrictionD by blast
lemma vlrestriction_atE2[elim]:
assumes "x ∈⇩∘ r ↾⇧l⇩∘ A"
obtains a b where "x = ⟨a, b⟩" and "a ∈⇩∘ A" and "r⦇a⦈ = b"
using assms by auto
text‹Right restriction.›
interpretation vrrestriction: vsv ‹r ↾⇧r⇩∘ A› by (rule vsv_vrrestriction)
lemma vrrestriction_atI[intro, simp]:
assumes "a ∈⇩∘ 𝒟⇩∘ r" and "b ∈⇩∘ A" and "r⦇a⦈ = b"
shows "(r ↾⇧r⇩∘ A)⦇a⦈ = b"
using assms by (auto simp: app_vrrestrictionI)
lemma vrrestriction_atD[dest]:
assumes "(r ↾⇧r⇩∘ A)⦇a⦈ = b" and "a ∈⇩∘ r -`⇩∘ A"
shows "b ∈⇩∘ A" and "r⦇a⦈ = b"
using assms by force+
lemma vrrestriction_atE1[elim]:
assumes "(r ↾⇧r⇩∘ A)⦇a⦈ = b" and "a ∈⇩∘ r -`⇩∘ A" and "r⦇a⦈ = b ⟹ P"
shows P
using assms by (auto simp: vrrestriction_atD(2))
lemma vrrestriction_atE2[elim]:
assumes "x ∈⇩∘ r ↾⇧r⇩∘ A"
obtains a b where "x = ⟨a, b⟩" and "b ∈⇩∘ A" and "r⦇a⦈ = b"
using assms unfolding vrrestriction_def by auto
text‹Restriction.›
interpretation vrestriction: vsv ‹r ↾⇩∘ A› by (rule vsv_vrestriction)
lemma vlrestriction_app[intro, simp]:
assumes "a ∈⇩∘ 𝒟⇩∘ r" and "a ∈⇩∘ A"
shows "(r ↾⇧l⇩∘ A)⦇a⦈ = r⦇a⦈"
using assms by auto
lemma vrestriction_atD[dest]:
assumes "(r ↾⇩∘ A)⦇a⦈ = b" and "a ∈⇩∘ r -`⇩∘ A" and "a ∈⇩∘ A"
shows "b ∈⇩∘ A" and "r⦇a⦈ = b"
proof-
from assms have "a ∈⇩∘ 𝒟⇩∘ r" by auto
then show "r⦇a⦈ = b"
by
(
metis
assms
app_invimageD1
vrrestriction.vlrestriction_atD
vrrestriction_atD(2)
vrrestriction_vlrestriction
)
then show "b ∈⇩∘ A" using assms(2) by blast
qed
lemma vrestriction_atE1[elim]:
assumes "(r ↾⇩∘ A)⦇a⦈ = b"
and "a ∈⇩∘ r -`⇩∘ A"
and "a ∈⇩∘ A"
and "r⦇a⦈ = b ⟹ P"
shows P
using assms vrestriction_atD(2) by blast
lemma vrestriction_atE2[elim]:
assumes "x ∈⇩∘ r ↾⇩∘ A"
obtains a b where "x = ⟨a, b⟩" and "a ∈⇩∘ A" and "b ∈⇩∘ A" and "r⦇a⦈ = b"
using assms unfolding vrestriction_def by clarsimp
text‹Domain.›
lemma vdomain_atD:
assumes "a ∈⇩∘ 𝒟⇩∘ r"
shows "∃b∈⇩∘ℛ⇩∘ r. r⦇a⦈ = b"
using assms by (blast intro: vsv_vimageI2)
lemma vdomain_atE:
assumes "a ∈⇩∘ 𝒟⇩∘ r"
obtains b where "b ∈⇩∘ ℛ⇩∘ r" and "r⦇a⦈ = b"
using assms by auto
text‹Range.›
lemma vrange_atD:
assumes "b ∈⇩∘ ℛ⇩∘ r"
shows "∃a∈⇩∘𝒟⇩∘ r. r⦇a⦈ = b"
using assms by auto
lemma vrange_atE:
assumes "b ∈⇩∘ ℛ⇩∘ r"
obtains a where "a ∈⇩∘ 𝒟⇩∘ r" and "r⦇a⦈ = b"
using assms by auto
text‹Image.›
lemma vimage_set_eq_at:
"{b. ∃a∈⇩∘A ∩⇩∘ 𝒟⇩∘ r. r⦇a⦈ = b} = {b. ∃a∈⇩∘A. ⟨a, b⟩ ∈⇩∘ r}"
by (rule subset_antisym; rule subsetI; unfold mem_Collect_eq) auto
lemma vimage_small[simp]: "small {b. ∃a∈⇩∘A ∩⇩∘ 𝒟⇩∘ r. r⦇a⦈ = b}"
unfolding vimage_set_eq_at by auto
lemma vimage_set_def: "r `⇩∘ A = set {b. ∃a∈⇩∘A ∩⇩∘ 𝒟⇩∘ r. r⦇a⦈ = b}"
unfolding vimage_set_eq_at by (simp add: app_vimage_set_def)
lemma vimage_set_iff: "b ∈⇩∘ r `⇩∘ A ⟷ (∃a∈⇩∘A ∩⇩∘ 𝒟⇩∘ r. r⦇a⦈ = b)"
unfolding vimage_set_eq_at using vsv_vimage_iff by auto
text‹Further derived results.›
lemma vimage_image:
assumes "A ⊆⇩∘ 𝒟⇩∘ r"
shows "elts (r `⇩∘ A) = (λx. r⦇x⦈) ` (elts A)"
using vimage_def assms small_elts by blast
lemma vsv_vinsert_match_appI[intro, simp]:
assumes "a ∉⇩∘ 𝒟⇩∘ r"
shows "vinsert ⟨a, b⟩ r ⦇a⦈ = b"
using assms vsv_axioms by simp
lemma vsv_vinsert_no_match_appI:
assumes "a ∉⇩∘ 𝒟⇩∘ r" and "c ∈⇩∘ 𝒟⇩∘ r" and "r ⦇c⦈ = d"
shows "vinsert ⟨a, b⟩ r ⦇c⦈ = d"
using assms vsv_axioms by simp
lemma vsv_is_vconst_onI:
assumes "𝒟⇩∘ r = A" and "ℛ⇩∘ r = set {a}"
shows "r = vconst_on A a"
unfolding assms(1)[symmetric]
proof(cases ‹𝒟⇩∘ r = 0›)
case True
with assms show "r = vconst_on (𝒟⇩∘ r) a"
by (auto simp: vdomain_vrange_is_vempty)
next
case False
show "r = vconst_on (𝒟⇩∘ r) a"
proof(rule vsv_eqI)
fix a' assume prems: "a' ∈⇩∘ 𝒟⇩∘ r"
then obtain b where "r⦇a'⦈ = b" and "b ∈⇩∘ ℛ⇩∘ r" by auto
moreover then have "b = a" unfolding assms by simp
ultimately show "r⦇a'⦈ = vconst_on (𝒟⇩∘ r) a⦇a'⦈" by (simp add: prems)
qed auto
qed
lemma vsv_vdomain_vrange_vsingleton:
assumes "𝒟⇩∘ r = set {a}" and "ℛ⇩∘ r = set{b}"
shows "r = set {⟨a, b⟩}"
using assms vsv_is_vconst_onI by auto
end
text‹Alternative forms of existing results.›
lemmas [intro] = vsv.vconverse_atI
and vsv_vconverse_atD[dest] = vsv.vconverse_atD[rotated]
and vsv_vconverse_atE[elim] = vsv.vconverse_atE[rotated]
and [intro, simp] = vsv.vlrestriction_atI
and vsv_vlrestriction_atD[dest] = vsv.vlrestriction_atD[rotated]
and vsv_vlrestriction_atE1[elim] = vsv.vlrestriction_atE1[rotated]
and vsv_vlrestriction_atE2[elim] = vsv.vlrestriction_atE2[rotated]
and [intro, simp] = vsv.vrrestriction_atI
and vsv_vrrestriction_atD[dest] = vsv.vrrestriction_atD[rotated]
and vsv_vrrestriction_atE1[elim] = vsv.vrrestriction_atE1[rotated]
and vsv_vrrestriction_atE2[elim] = vsv.vrrestriction_atE2[rotated]
and [intro, simp] = vsv.vlrestriction_app
and vsv_vrestriction_atD[dest] = vsv.vrestriction_atD[rotated]
and vsv_vrestriction_atE1[elim] = vsv.vrestriction_atE1[rotated]
and vsv_vrestriction_atE2[elim] = vsv.vrestriction_atE2[rotated]
and vsv_vdomain_atD = vsv.vdomain_atD[rotated]
and vsv_vdomain_atE = vsv.vdomain_atE[rotated]
and vrange_atD = vsv.vrange_atD[rotated]
and vrange_atE = vsv.vrange_atE[rotated]
and vsv_vinsert_match_appI[intro, simp] = vsv.vsv_vinsert_match_appI
and vsv_vinsert_no_match_appI[intro, simp] =
vsv.vsv_vinsert_no_match_appI[rotated 3]
text‹Corollaries of the alternative forms of existing results.›
lemma vsv_vlrestriction_vrange:
assumes "vsv s" and "vsv (r ↾⇧l⇩∘ ℛ⇩∘ s)"
shows "vsv (r ∘⇩∘ s)"
proof(rule vsvI)
show "vbrelation (r ∘⇩∘ s)" by auto
fix a c c' assume "⟨a, c⟩ ∈⇩∘ r ∘⇩∘ s" "⟨a, c'⟩ ∈⇩∘ r ∘⇩∘ s"
then obtain b and b'
where ab: "⟨a, b⟩ ∈⇩∘ s"
and bc: "⟨b, c⟩ ∈⇩∘ r"
and ab': "⟨a, b'⟩ ∈⇩∘ s"
and b'c': "⟨b', c'⟩ ∈⇩∘ r"
by clarsimp
moreover then have "b ∈⇩∘ ℛ⇩∘ s" and "b' ∈⇩∘ ℛ⇩∘ s" by auto
ultimately have "⟨b, c⟩ ∈⇩∘ (r ↾⇧l⇩∘ ℛ⇩∘ s)" and "⟨b', c'⟩ ∈⇩∘ (r ↾⇧l⇩∘ ℛ⇩∘ s)" by auto
with ab ab' have "⟨a, c⟩ ∈⇩∘ (r ↾⇧l⇩∘ ℛ⇩∘ s) ∘⇩∘ s" and "⟨a, c'⟩ ∈⇩∘ (r ↾⇧l⇩∘ ℛ⇩∘ s) ∘⇩∘ s"
by blast+
moreover from assms have "vsv ((r ↾⇧l⇩∘ ℛ⇩∘ s) ∘⇩∘ s)" by (intro vsv_vcomp)
ultimately show "c = c'" by auto
qed
lemma vsv_vunion_app_right[simp]:
assumes "vsv r" and "vsv s" and "vdisjnt (𝒟⇩∘ r) (𝒟⇩∘ s)" and "x ∈⇩∘ 𝒟⇩∘ s"
shows "(r ∪⇩∘ s)⦇x⦈ = s⦇x⦈"
using assms vsubsetD by blast
lemma vsv_vunion_app_left[simp]:
assumes "vsv r" and "vsv s" and "vdisjnt (𝒟⇩∘ r) (𝒟⇩∘ s)" and "x ∈⇩∘ 𝒟⇩∘ r"
shows "(r ∪⇩∘ s)⦇x⦈ = r⦇x⦈"
using assms vsubsetD by blast
subsubsection‹One-to-one relation›
locale v11 = vsv r for r +
assumes vsv_vconverse: "vsv (r¯⇩∘)"
text‹Rules.›
lemmas (in v11) [intro] = v11_axioms
mk_ide rf v11_def[unfolded v11_axioms_def]
|intro v11I[intro]|
|dest v11D[dest]|
|elim v11E[elim]|
text‹Set operations.›
lemma (in v11) v11_vinsert[intro, simp]:
assumes "a ∉⇩∘ 𝒟⇩∘ r" and "b ∉⇩∘ ℛ⇩∘ r"
shows "v11 (vinsert ⟨a, b⟩ r)"
using assms v11_axioms
by (intro v11I; elim v11E) (simp_all add: vconverse_vinsert vsv.vsv_vinsert)
lemma v11_vinsertD:
assumes "v11 (vinsert x r)"
shows "v11 r"
using assms by (intro v11I) (auto simp: vsv_vinsertD)
lemma v11_vunion:
assumes "v11 r"
and "v11 s"
and "vdisjnt (𝒟⇩∘ r) (𝒟⇩∘ s)"
and "vdisjnt (ℛ⇩∘ r) (ℛ⇩∘ s)"
shows "v11 (r ∪⇩∘ s)"
proof
interpret r: v11 r by (rule assms(1))
interpret s: v11 s by (rule assms(2))
show "vsv (r ∪⇩∘ s)" by (simp add: assms v11D)
from assms show "vsv ((r ∪⇩∘ s)¯⇩∘)"
by (simp add: assms r.vsv_vconverse s.vsv_vconverse vconverse_vunion)
qed
lemma (in v11) v11_vintersection[intro, simp]: "v11 (r ∩⇩∘ s)"
using v11_axioms by (intro v11I) auto
lemma (in v11) v11_vdiff[intro, simp]: "v11 (r -⇩∘ s)"
using v11_axioms by (intro v11I) auto
text‹Special properties.›
lemma (in vsv) vsv_valneq_v11I:
assumes "⋀x y. ⟦ x ∈⇩∘ 𝒟⇩∘ r; y ∈⇩∘ 𝒟⇩∘ r; x ≠ y ⟧ ⟹ r⦇x⦈ ≠ r⦇y⦈"
shows "v11 r"
proof(intro v11I)
from vsv_axioms show "vsv r" by simp
show "vsv (r¯⇩∘)"
by
(
metis
assms
vbrelation_vconverse
vconverse_atD
app_vrangeI
vrange_vconverse
vsvI
)
qed
lemma (in vsv) vsv_valeq_v11I:
assumes "⋀x y. ⟦ x ∈⇩∘ 𝒟⇩∘ r; y ∈⇩∘ 𝒟⇩∘ r; r⦇x⦈ = r⦇y⦈ ⟧ ⟹ x = y"
shows "v11 r"
using assms vsv_valneq_v11I by auto
text‹Connections.›
lemma v11_vempty[simp]: "v11 0" by (simp add: v11I)
lemma v11_vsingleton[simp]: "v11 (set {⟨a, b⟩})" by auto
lemma v11_vdoubleton:
assumes "a ≠ c" and "b ≠ d"
shows "v11 (set {⟨a, b⟩, ⟨c, d⟩})"
using assms by (auto simp: vinsert_set_insert_eq)
lemma v11_vid_on[simp]: "v11 (vid_on A)" by auto
lemma v11_VLambda[intro]:
assumes "inj_on f (elts A)"
shows "v11 (λa∈⇩∘A. f a)"
proof(rule rel_VLambda.vsv_valneq_v11I)
fix x y
assume "x ∈⇩∘ 𝒟⇩∘ (λa∈⇩∘A. f a)" and "y ∈⇩∘ 𝒟⇩∘ (λa∈⇩∘A. f a)" and "x ≠ y"
then have "x ∈⇩∘ A" and "y ∈⇩∘ A" by auto
with assms ‹x ≠ y› have "f x ≠ f y" by (auto dest: inj_onD)
then show "(λa∈⇩∘A. f a)⦇x⦈ ≠ (λa∈⇩∘A. f a)⦇y⦈"
by (simp add: ‹x ∈⇩∘ A› ‹y ∈⇩∘ A›)
qed
lemma v11_vcomp:
assumes "v11 r" and "v11 s"
shows "v11 (r ∘⇩∘ s)"
using assms by (intro v11I; elim v11E) (auto simp: vsv_vcomp vconverse_vcomp)
context v11
begin
lemma v11_vconverse: "v11 (r¯⇩∘)" by (auto simp: vsv_axioms vsv_vconverse)
interpretation v11 ‹r¯⇩∘› by (rule v11_vconverse)
lemma v11_vlrestriction[intro, simp]: "v11 (r ↾⇧l⇩∘ A)"
using vsv_vrrestriction by (auto simp: vrrestriction_vconverse)
lemma v11_vrrestriction[intro, simp]: "v11 (r ↾⇧r⇩∘ A)"
using vsv_vlrestriction by (auto simp: vlrestriction_vconverse)
lemma v11_vrestriction[intro, simp]: "v11 (r ↾⇩∘ A)"
using vsv_vrestriction by (auto simp: vrestriction_vconverse)
end
text‹Further Special properties.›
context v11
begin
lemma v11_injective:
assumes "a ∈⇩∘ 𝒟⇩∘ r" and "b ∈⇩∘ 𝒟⇩∘ r" and "r⦇a⦈ = r⦇b⦈"
shows "a = b"
using assms v11_axioms by auto
lemma v11_double_pair:
assumes "a ∈⇩∘ 𝒟⇩∘ r" and "a' ∈⇩∘ 𝒟⇩∘ r" and "r⦇a⦈ = b" and "r⦇a'⦈ = b'"
shows "a = a' ⟷ b = b'"
using assms v11_axioms by auto
lemma v11_vrange_ex1_eq: "b ∈⇩∘ ℛ⇩∘ r ⟷ (∃!a∈⇩∘𝒟⇩∘ r. r⦇a⦈ = b)"
proof(rule iffI)
from app_vdomainI v11_injective show
"b ∈⇩∘ ℛ⇩∘ r ⟹ ∃!a. a ∈⇩∘ 𝒟⇩∘ r ∧ r⦇a⦈ = b"
by (elim app_vrangeE) auto
show "∃!a. a ∈⇩∘ 𝒟⇩∘ r ∧ r⦇a⦈ = b ⟹ b ∈⇩∘ ℛ⇩∘ r"
by (auto intro: vsv_vimageI2)
qed
lemma v11_VLambda_iff: "inj_on f (elts A) ⟷ v11 (λa∈⇩∘A. f a)"
by (rule iffI; (intro inj_onI | tactic‹all_tac›))
(auto simp: v11.v11_injective)
lemma v11_vimage_vpsubset_neq:
assumes "A ⊆⇩∘ 𝒟⇩∘ r" and "B ⊆⇩∘ 𝒟⇩∘ r" and "A ≠ B"
shows "r `⇩∘ A ≠ r `⇩∘ B"
proof-
from assms obtain a where AB: "a ∈⇩∘ A ∨ a ∈⇩∘ B" and nAB: "a ∉⇩∘ A ∨ a ∉⇩∘ B"
by auto
then have "r⦇a⦈ ∉⇩∘ r `⇩∘ A ∨ r⦇a⦈ ∉⇩∘ r `⇩∘ B"
unfolding vsv_vimage_iff by (metis assms(1,2) v11_injective vsubsetD)
moreover from AB nAB assms(1,2) have "r⦇a⦈ ∈⇩∘ r `⇩∘ A ∨ r⦇a⦈ ∈⇩∘ r `⇩∘ B"
by auto
ultimately show "r `⇩∘ A ≠ r `⇩∘ B" by clarsimp
qed
lemma v11_eq_iff[simp]:
assumes "a ∈⇩∘ 𝒟⇩∘ r" and "b ∈⇩∘ 𝒟⇩∘ r"
shows "r⦇a⦈ = r⦇b⦈ ⟷ a = b"
using assms v11_double_pair by blast
lemma v11_vcomp_vconverse: "r¯⇩∘ ∘⇩∘ r = vid_on (𝒟⇩∘ r)"
proof(intro vsubset_antisym vsubsetI)
fix x assume prems: "x ∈⇩∘ r¯⇩∘ ∘⇩∘ r"
then obtain a c where x_def: "x = ⟨a, c⟩" and a: "a ∈⇩∘ 𝒟⇩∘ r" by auto
with prems obtain b where "⟨a, b⟩ ∈⇩∘ r" and "⟨b, c⟩ ∈⇩∘ r¯⇩∘" by auto
with v11.vsv_vconverse v11_axioms have ca: "c = a" by auto
from a show "x ∈⇩∘ vid_on (𝒟⇩∘ r)" unfolding x_def ca by auto
next
fix x assume "x ∈⇩∘ vid_on (𝒟⇩∘ r)"
then obtain a where x_def: "x = ⟨a, a⟩" and a: "a ∈⇩∘ 𝒟⇩∘ r" by clarsimp
then obtain b where "⟨a, b⟩ ∈⇩∘ r" by auto
then show "x ∈⇩∘ r¯⇩∘ ∘⇩∘ r" unfolding x_def using a by auto
qed
lemma v11_vcomp_vconverse': "r ∘⇩∘ r¯⇩∘ = vid_on (ℛ⇩∘ r)"
using v11.v11_vcomp_vconverse v11_vconverse by force
lemma v11_vconverse_app[simp]:
assumes "r⦇a⦈ = b" and "a ∈⇩∘ 𝒟⇩∘ r"
shows "r¯⇩∘⦇b⦈ = a"
using assms by (simp add: vsv.vconverse_iff vsv_axioms vsv_vconverse)
lemma v11_vconverse_app_in_vdomain:
assumes "y ∈⇩∘ ℛ⇩∘ r"
shows "r¯⇩∘⦇y⦈ ∈⇩∘ 𝒟⇩∘ r"
using assms v11_vconverse
unfolding vrange_vconverse[symmetric]
by (auto simp: v11_def)
lemma v11_app_if_vconverse_app:
assumes "y ∈⇩∘ ℛ⇩∘ r" and "r¯⇩∘⦇y⦈ = x"
shows "r⦇x⦈ = y"
using assms vsv_vconverse by auto
lemma v11_app_vconverse_app:
assumes "a ∈⇩∘ ℛ⇩∘ r"
shows "r⦇r¯⇩∘⦇a⦈⦈ = a"
using assms by (meson v11_app_if_vconverse_app)
lemma v11_vconverse_app_app:
assumes "a ∈⇩∘ 𝒟⇩∘ r"
shows "r¯⇩∘⦇r⦇a⦈⦈ = a"
using assms v11_vconverse_app by auto
end
lemma v11_vlrestriction_vsubset:
assumes "v11 (f ↾⇧l⇩∘ A)" and "B ⊆⇩∘ A"
shows "v11 (f ↾⇧l⇩∘ B)"
proof-
from assms have fB_def: "f ↾⇧l⇩∘ B = (f ↾⇧l⇩∘ A) ↾⇧l⇩∘ B" by auto
show ?thesis unfolding fB_def by (intro v11.v11_vlrestriction assms(1))
qed
lemma v11_vlrestriction_vrange:
assumes "v11 s" and "v11 (r ↾⇧l⇩∘ ℛ⇩∘ s)"
shows "v11 (r ∘⇩∘ s)"
proof(intro v11I)
interpret v11 s by (rule assms(1))
from assms vsv_vlrestriction_vrange show "vsv (r ∘⇩∘ s)"
by (simp add: v11.axioms(1))
show "vsv ((r ∘⇩∘ s)¯⇩∘)"
unfolding vconverse_vcomp
proof(rule vsvI)
fix a c c' assume "⟨a, c⟩ ∈⇩∘ s¯⇩∘ ∘⇩∘ r¯⇩∘" "⟨a, c'⟩ ∈⇩∘ s¯⇩∘ ∘⇩∘ r¯⇩∘"
then obtain b and b'
where "⟨b, a⟩ ∈⇩∘ r"
and bc: "⟨c, b⟩ ∈⇩∘ s"
and "⟨b', a⟩ ∈⇩∘ r"
and b'c': "⟨c', b'⟩ ∈⇩∘ s"
by auto
moreover then have "b ∈⇩∘ ℛ⇩∘ s" and "b' ∈⇩∘ ℛ⇩∘ s" by auto
ultimately have "⟨b, a⟩ ∈⇩∘ (r ↾⇧l⇩∘ ℛ⇩∘ s)" and "⟨b', a⟩ ∈⇩∘ (r ↾⇧l⇩∘ ℛ⇩∘ s)" by auto
with assms(2) have bb': "b = b'" by auto
from assms bc[unfolded bb'] b'c' show "c = c'" by auto
qed auto
qed
lemma v11_vlrestriction_vcomp:
assumes "v11 (f ↾⇧l⇩∘ A)" and "v11 (g ↾⇧l⇩∘ (f `⇩∘ A))"
shows "v11 ((g ∘⇩∘ f) ↾⇧l⇩∘ A)"
using assms v11_vlrestriction_vrange by (auto simp: assms(2) app_vimage_def)
text‹Alternative forms of existing results.›
lemmas [intro, simp] = v11.v11_vinsert
and [intro, simp] = v11.v11_vintersection
and [intro, simp] = v11.v11_vdiff
and [intro, simp] = v11.v11_vrrestriction
and [intro, simp] = v11.v11_vlrestriction
and [intro, simp] = v11.v11_vrestriction
and [intro] = v11.v11_vimage_vpsubset_neq
subsection‹Tools: ‹mk_VLambda››
ML‹
fun pure_unfold ctxt thms = ctxt
|>
(
thms
|> Conv.rewrs_conv
|> Conv.try_conv
|> K
|> Conv.top_conv
)
|> Conv.fconv_rule;
val msg_args = "mk_VLambda: invalid arguments"
val vsv_VLambda_thm = @{thm vsv_VLambda};
val vsv_VLambda_match = vsv_VLambda_thm
|> Thm.full_prop_of
|> HOLogic.dest_Trueprop
|> dest_comb
|> #2;
val vdomain_VLambda_thm = @{thm vdomain_VLambda};
val vdomain_VLambda_match = vdomain_VLambda_thm
|> Thm.full_prop_of
|> HOLogic.dest_Trueprop
|> HOLogic.dest_eq
|> #1
|> dest_comb
|> #2;
val app_VLambda_thm = @{thm ZFC_Cardinals.beta};
val app_VLambda_match = app_VLambda_thm
|> Thm.concl_of
|> HOLogic.dest_Trueprop
|> HOLogic.dest_eq
|> #1
|> strip_comb
|> #2
|> hd;
fun mk_VLabmda_thm match_t match_thm ctxt thm =
let
val thm_ct = Thm.cprop_of thm
val (_, rhs_ct) = Thm.dest_equals thm_ct
handle TERM ("dest_equals", _) => error msg_args
val insts = Thm.match (Thm.cterm_of ctxt match_t, rhs_ct)
handle Pattern.MATCH => error msg_args
in
match_thm
|> Drule.instantiate_normalize insts
|> pure_unfold ctxt (thm |> Thm.symmetric |> single)
end;
val mk_VLambda_vsv =
mk_VLabmda_thm vsv_VLambda_match vsv_VLambda_thm;
val mk_VLambda_vdomain =
mk_VLabmda_thm vdomain_VLambda_match vdomain_VLambda_thm;
val mk_VLambda_app =
mk_VLabmda_thm app_VLambda_match app_VLambda_thm;
val mk_VLambda_parser = Parse.thm --
(
Scan.repeat
(
(\<^keyword>‹|vsv› -- Parse_Spec.opt_thm_name "|") ||
(\<^keyword>‹|app› -- Parse_Spec.opt_thm_name "|") ||
(\<^keyword>‹|vdomain› -- Parse_Spec.opt_thm_name "|")
)
);
fun process_mk_VLambda_thm mk_VLambda_thm (b, thm) ctxt =
let
val thm' = mk_VLambda_thm ctxt thm
val ((c, thms'), ctxt') = ctxt
|> Local_Theory.note (b ||> map (Attrib.check_src ctxt), single thm')
val _ = IDE_Utilities.thm_printer ctxt' true c thms'
in ctxt' end;
fun folder_mk_VLambda (("|vsv", b), thm) ctxt =
process_mk_VLambda_thm mk_VLambda_vsv (b, thm) ctxt
| folder_mk_VLambda (("|app", b), thm) ctxt =
process_mk_VLambda_thm mk_VLambda_app (b, thm) ctxt
| folder_mk_VLambda (("|vdomain", b), thm) ctxt =
process_mk_VLambda_thm mk_VLambda_vdomain (b, thm) ctxt
| folder_mk_VLambda _ _ = error msg_args
fun process_mk_VLambda (thm, ins) ctxt =
let
val _ = ins |> map fst |> has_duplicates op= |> not orelse error msg_args
val thm' = thm
|> singleton (Attrib.eval_thms ctxt)
|> Local_Defs.meta_rewrite_rule ctxt;
in fold folder_mk_VLambda (map (fn x => (x, thm')) ins) ctxt end;
val _ =
Outer_Syntax.local_theory
\<^command_keyword>‹mk_VLambda›
"VLambda"
(mk_VLambda_parser >> process_mk_VLambda);
›
text‹\newpage›
end
Theory CZH_Sets_IF
section‹Operations on indexed families of sets›
theory CZH_Sets_IF
imports CZH_Sets_BRelations
begin
subsection‹Background›
text‹
This section presents results about the fundamental operations on the indexed
families of sets, such as unions and intersections of the indexed families
of sets, disjoint unions and infinite Cartesian products.
Certain elements of the content of this section were inspired by
elements of the content of \cite{paulson_hereditarily_2013}.
However, as previously, many other results were ported (with amendments) from
the main library of Isabelle/HOL.
›
abbreviation (input) imVLambda :: "V ⇒ (V ⇒ V) ⇒ V"
where "imVLambda A f ≡ (λa∈⇩∘A. f a) `⇩∘ A"
subsection‹Intersection of an indexed family of sets›
syntax "_VIFINTER" :: "pttrn ⇒ V ⇒ V ⇒ V" (‹(3⋂⇩∘_∈⇩∘_./ _)› [0, 0, 10] 10)
translations "⋂⇩∘x∈⇩∘A. f" ⇌ "CONST VInter (CONST imVLambda A (λx. f))"
text‹Rules.›
lemma vifintersectionI[intro]:
assumes "I ≠ 0" and "⋀i. i ∈⇩∘ I ⟹ a ∈⇩∘ f i"
shows "a ∈⇩∘ (⋂⇩∘i∈⇩∘I. f i)"
using assms by (auto intro!: vsubset_antisym)
lemma vifintersectionD[dest]:
assumes "a ∈⇩∘ (⋂⇩∘i∈⇩∘I. f i)" and "i ∈⇩∘ I"
shows "a ∈⇩∘ f i"
using assms by blast
lemma vifintersectionE1[elim]:
assumes "a ∈⇩∘ (⋂⇩∘i∈⇩∘I. f i)" and "a ∈⇩∘ f i ⟹ P" and "i ∉⇩∘ I ⟹ P"
shows P
using assms by blast
lemma vifintersectionE3[elim]:
assumes "a ∈⇩∘ (⋂⇩∘i∈⇩∘I. f i)"
obtains "⋀i. i∈⇩∘I ⟹ a ∈⇩∘ f i"
using assms by blast
lemma vifintersectionE2[elim]:
assumes "a ∈⇩∘ (⋂⇩∘i∈⇩∘I. f i)"
obtains i where "i ∈⇩∘ I" and "a ∈⇩∘ f i"
using assms by (elim vifintersectionE3) (meson assms VInterE2 app_vimageE)
text‹Set operations.›
lemma vifintersection_vempty_is[simp]: "(⋂⇩∘i∈⇩∘0. f i) = 0" by auto
lemma vifintersection_vsingleton_is[simp]: "(⋂⇩∘i∈⇩∘set{i}. f i) = f i"
using elts_0 by blast
lemma vifintersection_vdoubleton_is[simp]: "(⋂⇩∘i∈⇩∘set {i, j}. f i) = f i ∩⇩∘ f j"
by
(
intro vsubset_antisym vsubsetI;
(elim vifintersectionE3 | intro vifintersectionI)
)
auto
lemma vifintersection_antimono1:
assumes "I ≠ 0" and "I ⊆⇩∘ J"
shows "(⋂⇩∘j∈⇩∘J. f j) ⊆⇩∘ (⋂⇩∘i∈⇩∘I. f i)"
using assms by blast
lemma vifintersection_antimono2:
assumes "I ≠ 0" and " I ⊆⇩∘ J" and "⋀i. i ∈⇩∘ I ⟹ f i ⊆⇩∘ g i"
shows "(⋂⇩∘j∈⇩∘J. f j) ⊆⇩∘ (⋂⇩∘i∈⇩∘I. g i)"
using assms by blast
lemma vifintersection_vintersection:
assumes "I ≠ 0" and "J ≠ 0"
shows "(⋂⇩∘i∈⇩∘I. f i) ∩⇩∘ (⋂⇩∘i∈⇩∘J. f i) = (⋂⇩∘i∈⇩∘I ∪⇩∘ J. f i)"
using assms by (auto intro!: vsubset_antisym)
lemma vifintersection_vintersection_family:
assumes "I ≠ 0"
shows "(⋂⇩∘i∈⇩∘I. A i) ∩⇩∘ (⋂⇩∘i∈⇩∘I. B i) = (⋂⇩∘i∈⇩∘I. A i ∩⇩∘ B i)"
using assms
by (intro vsubset_antisym vsubsetI, intro vifintersectionI | tactic‹all_tac›)
blast+
lemma vifintersection_vunion:
assumes "I ≠ 0" and "J ≠ 0"
shows "(⋂⇩∘i∈⇩∘I. f i) ∪⇩∘ (⋂⇩∘j∈⇩∘J. g j) = (⋂⇩∘i∈⇩∘I. ⋂⇩∘j∈⇩∘J. f i ∪⇩∘ g j)"
using assms by (blast intro!: vsubset_antisym)
lemma vifintersection_vinsert_is[intro, simp]:
assumes "I ≠ 0"
shows "(⋂⇩∘i ∈⇩∘ vinsert j I. f i) = f j ∩⇩∘ (⋂⇩∘i∈⇩∘I. f i)"
apply(insert assms, intro vsubset_antisym vsubsetI)
subgoal for b by (subgoal_tac ‹b ∈⇩∘ f j› ‹b ∈⇩∘ (⋂⇩∘i∈⇩∘I. f i)›) blast+
subgoal for b
by (subgoal_tac ‹b ∈⇩∘ f j› ‹b ∈⇩∘ (⋂⇩∘i∈⇩∘I. f i)›)
(blast intro!: vsubset_antisym)+
done
lemma vifintersection_VPow:
assumes "I ≠ 0"
shows "VPow (⋂⇩∘i∈⇩∘I. f i) = (⋂⇩∘i∈⇩∘I. VPow (f i))"
using assms by (auto intro!: vsubset_antisym)
text‹Elementary properties.›
lemma vifintersection_constant[intro, simp]:
assumes "I ≠ 0"
shows "(⋂⇩∘y∈⇩∘I. c) = c"
using assms by auto
lemma vifintersection_vsubset_iff:
assumes "I ≠ 0"
shows "A ⊆⇩∘ (⋂⇩∘i∈⇩∘I. f i) ⟷ (∀i∈⇩∘I. A ⊆⇩∘ f i)"
using assms by blast
lemma vifintersection_vsubset_lower:
assumes "i ∈⇩∘ I"
shows "(⋂⇩∘i∈⇩∘I. f i) ⊆⇩∘ f i"
using assms by blast
lemma vifintersection_vsubset_greatest:
assumes "I ≠ 0" and "⋀i. i ∈⇩∘ I ⟹ A ⊆⇩∘ f i"
shows "A ⊆⇩∘ (⋂⇩∘i∈⇩∘I. f i)"
using assms by (intro vsubsetI vifintersectionI) auto
lemma vifintersection_vintersection_value:
assumes "i ∈⇩∘ I"
shows "f i ∩⇩∘ (⋂⇩∘i∈⇩∘I. f i) = (⋂⇩∘i∈⇩∘I. f i)"
using assms by blast
lemma vifintersection_vintersection_single:
assumes "I ≠ 0"
shows "B ∪⇩∘ (⋂⇩∘i∈⇩∘I. A i) = (⋂⇩∘i∈⇩∘I. B ∪⇩∘ A i)"
by (insert assms, intro vsubset_antisym vsubsetI vifintersectionI)
blast+
text‹Connections.›
lemma vifintersection_vrange_VLambda: "(⋂⇩∘i∈⇩∘I. f i) = ⋂⇩∘ (ℛ⇩∘ (λa∈⇩∘I. f a))"
by (simp add: vimage_VLambda_vrange_rep)
subsection‹Union of an indexed family of sets›
syntax "_VIFUNION" :: "pttrn ⇒ V ⇒ V ⇒ V" (‹(3⋃⇩∘_∈⇩∘_./ _)› [0, 0, 10] 10)
translations "⋃⇩∘x∈⇩∘A. f" ⇌ "CONST VUnion (CONST imVLambda A (λx. f))"
text‹Rules.›
lemma vifunion_iff: "b ∈⇩∘ (⋃⇩∘i∈⇩∘I. f i) ⟷ (∃i∈⇩∘I. b ∈⇩∘ f i)" by force
lemma vifunionI[intro]:
assumes "i ∈⇩∘ I" and "a ∈⇩∘ f i"
shows "a ∈⇩∘ (⋃⇩∘i∈⇩∘I. f i)"
using assms by force
lemma vifunionD[dest]:
assumes "a ∈⇩∘ (⋃⇩∘i∈⇩∘I. f i)"
shows "∃i∈⇩∘I. a ∈⇩∘ f i"
using assms by auto
lemma vifunionE[elim!]:
assumes "a ∈⇩∘ (⋃⇩∘i∈⇩∘I. f i)" and "⋀i. ⟦ i ∈⇩∘ I; a ∈⇩∘ f i ⟧ ⟹ R"
shows R
using assms by auto
text‹Set operations.›
lemma vifunion_vempty_family[simp]: "(⋃⇩∘i∈⇩∘I. 0) = 0" by auto
lemma vifunion_vsingleton_is[simp]: "(⋃⇩∘i∈⇩∘set {i}. f i) = f i" by force
lemma vifunion_vsingleton_family[simp]: "(⋃⇩∘i∈⇩∘I. set {i}) = I" by force
lemma vifunion_vdoubleton: "(⋃⇩∘i∈⇩∘set {i, j}. f i) = f i ∪⇩∘ f j"
using VLambda_vinsert vimage_vunion_left
by (force simp: VLambda_vsingleton simp: vinsert_set_insert_eq)
lemma vifunion_mono:
assumes "I ⊆⇩∘ J" and "⋀i. i ∈⇩∘ I ⟹ f i ⊆⇩∘ g i"
shows "(⋃⇩∘i∈⇩∘I. f i) ⊆⇩∘ (⋃⇩∘j∈⇩∘J. g j)"
using assms by force
lemma vifunion_vunion_is: "(⋃⇩∘i∈⇩∘I. f i) ∪⇩∘ (⋃⇩∘j∈⇩∘J. f j) = (⋃⇩∘i∈⇩∘I ∪⇩∘ J. f i)"
by force
lemma vifunion_vunion_family:
"(⋃⇩∘i∈⇩∘I. f i) ∪⇩∘ (⋃⇩∘i∈⇩∘I. g i) = (⋃⇩∘i∈⇩∘I. f i ∪⇩∘ g i)"
by (intro vsubset_antisym vsubsetI; elim vunionE vifunionE) force+
lemma vifunion_vintersection:
"(⋃⇩∘i∈⇩∘I. f i) ∩⇩∘ (⋃⇩∘j∈⇩∘J. g j) = (⋃⇩∘i∈⇩∘I. ⋃⇩∘j∈⇩∘J. f i ∩⇩∘ g j)"
by (force simp: vrange_VLambda vimage_VLambda_vrange_rep)
lemma vifunion_vinsert_is:
"(⋃⇩∘i∈⇩∘vinsert j I. f i) = f j ∪⇩∘ (⋃⇩∘i∈⇩∘I. f i)"
by (force simp: vimage_VLambda_vrange_rep)
lemma vifunion_VPow: "(⋃⇩∘i∈⇩∘I. VPow (f i)) ⊆⇩∘ VPow (⋃⇩∘i∈⇩∘I. f i)" by force
text‹Elementary properties.›
lemma vifunion_vempty_conv:
"0 = (⋃⇩∘i∈⇩∘I. f i) ⟷ (∀i∈⇩∘I. f i = 0)"
"(⋃⇩∘i∈⇩∘I. f i) = 0 ⟷ (∀i∈⇩∘I. f i = 0)"
by (auto simp: vrange_VLambda vimage_VLambda_vrange_rep)
lemma vifunion_constant[simp]: "(⋃⇩∘i∈⇩∘I. c) = (if I = 0 then 0 else c)"
proof(intro vsubset_antisym)
show "(if I = 0 then 0 else c) ⊆⇩∘ (⋃⇩∘i∈⇩∘I. c)"
by (cases ‹vdisjnt I I›) (auto simp: VLambda_vconst_on)
qed auto
lemma vifunion_upper:
assumes "i ∈⇩∘ I"
shows "f i ⊆⇩∘ (⋃⇩∘i∈⇩∘I. f i)"
using assms by force
lemma vifunion_least:
assumes "⋀i. i ∈⇩∘ I ⟹ f i ⊆⇩∘ C"
shows "(⋃⇩∘i∈⇩∘I. f i) ⊆⇩∘ C"
using assms by auto
lemma vifunion_absorb:
assumes "j ∈⇩∘ I"
shows "f j ∪⇩∘ (⋃⇩∘i∈⇩∘I. f i) = (⋃⇩∘i∈⇩∘I. f i)"
using assms by force
lemma vifunion_vifunion_flatten:
"(⋃⇩∘j∈⇩∘(⋃⇩∘i∈⇩∘I. f i). g j) = (⋃⇩∘i∈⇩∘I. ⋃⇩∘j∈⇩∘f i. g j)"
by (force simp: vrange_VLambda vimage_VLambda_vrange_rep)
lemma vifunion_vsubset_iff: "((⋃⇩∘i∈⇩∘I. f i) ⊆⇩∘ B) = (∀i∈⇩∘I. f i ⊆⇩∘ B)" by force
lemma vifunion_vsingleton_eq_vrange: "(⋃⇩∘i∈⇩∘I. set {f i}) = ℛ⇩∘ (λa∈⇩∘I. f a)"
by force
lemma vball_vifunion[simp]: "(∀z∈⇩∘(⋃⇩∘i∈⇩∘I. f i). P z) ⟷ (∀x∈⇩∘I. ∀z∈⇩∘f x. P z)"
by force
lemma vbex_vifunion[simp]: "(∃z∈⇩∘(⋃⇩∘i∈⇩∘I. f i). P z) ⟷ (∃x∈⇩∘I. ∃z∈⇩∘f x. P z)"
by force
lemma vifunion_vintersection_index_right[simp]: "(⋃⇩∘C∈⇩∘B. A ∩⇩∘ C) = A ∩⇩∘ ⋃⇩∘B"
by (force simp: vimage_VLambda_vrange_rep)
lemma vifunion_vintersection_index_left[simp]: "(⋃⇩∘C∈⇩∘B. C ∩⇩∘ A) = ⋃⇩∘B ∩⇩∘ A"
by (force simp: vimage_VLambda_vrange_rep)
lemma vifunion_vunion_index[intro, simp]:
assumes "B ≠ 0"
shows "(⋂⇩∘C∈⇩∘B. A ∪⇩∘ C) = A ∪⇩∘ ⋂⇩∘B"
using assms
by
(
(intro vsubset_antisym vsubsetI);
(intro vifintersectionI | tactic‹all_tac›)
)
blast+
lemma vifunion_vintersection_single: "B ∩⇩∘ (⋃⇩∘i∈⇩∘I. f i) = (⋃⇩∘i∈⇩∘I. B ∩⇩∘ f i)"
by (force simp: vrange_VLambda vimage_VLambda_vrange_rep)
lemma vifunion_vifunion_flip:
"(⋃⇩∘b∈⇩∘B. ⋃⇩∘a∈⇩∘A. f b a) = (⋃⇩∘a∈⇩∘A. ⋃⇩∘b∈⇩∘B. f b a)"
proof-
have "x ∈⇩∘ (⋃⇩∘a∈⇩∘A. ⋃⇩∘b∈⇩∘B. f b a)" if "x ∈⇩∘ (⋃⇩∘b∈⇩∘B. ⋃⇩∘a∈⇩∘A. f b a)"
for x f A B
proof-
from that obtain b where b: "b ∈⇩∘ B" and x_b: "x ∈⇩∘ (⋃⇩∘a∈⇩∘A. f b a)"
by fastforce
then obtain a where a: "a ∈⇩∘ A" and x_fba: "x ∈⇩∘ f b a" by fastforce
show "x ∈⇩∘ (⋃⇩∘a∈⇩∘A. ⋃⇩∘b∈⇩∘B. f b a)"
unfolding vifunion_iff by (auto intro: a b x_fba)
qed
then show ?thesis by (intro vsubset_antisym vsubsetI) auto
qed
text‹Connections.›
lemma vifunion_disjoint: "(⋃⇩∘C ∩⇩∘ A = 0) ⟷ (∀B∈⇩∘C. vdisjnt B A)"
by (intro iffI)
(auto intro!: vsubset_antisym simp: Sup_upper vdisjnt_vsubset_left)
lemma vdisjnt_vifunion_iff:
"vdisjnt A (⋃⇩∘i∈⇩∘I. f i) ⟷ (∀i∈⇩∘I. vdisjnt A (f i))"
by (force intro!: vsubset_antisym simp: vdisjnt_iff)+
lemma vifunion_VLambda: "(⋃⇩∘i∈⇩∘A. set {⟨i, f i⟩}) = (λa∈⇩∘A. f a)"
using vifunionI by (intro vsubset_antisym vsubsetI) auto
lemma vifunion_vrange_VLambda: "(⋃⇩∘i∈⇩∘I. f i) = ⋃⇩∘(ℛ⇩∘ (λa∈⇩∘I. f a))"
using vimage_VLambda_vrange_rep by auto
lemma (in vsv) vsv_vrange_vsubset_vifunion_app:
assumes "𝒟⇩∘ r = I" and "⋀i. i ∈⇩∘ I ⟹ r⦇i⦈ ∈⇩∘ A i"
shows "ℛ⇩∘ r ⊆⇩∘ (⋃⇩∘i∈⇩∘I. A i)"
proof(intro vsubsetI)
fix x assume "x ∈⇩∘ ℛ⇩∘ r"
with assms(1) obtain i where x_def: "x = r⦇i⦈" and i: "i ∈⇩∘ I"
by (metis vrange_atE)
from i assms(2)[rule_format, OF i] show "x ∈⇩∘ (⋃⇩∘i∈⇩∘I. A i)"
unfolding x_def by (intro vifunionI) auto
qed
lemma v11_vlrestriction_vifintersection:
assumes "I ≠ 0" and "⋀i. i ∈⇩∘ I ⟹ v11 (f ↾⇧l⇩∘ (A i))"
shows "v11 (f ↾⇧l⇩∘ (⋂⇩∘i∈⇩∘I. A i))"
proof(intro v11I)
show "vsv (f ↾⇧l⇩∘ ⋂⇩∘ ((λa∈⇩∘I. A a) `⇩∘ I))"
apply(subgoal_tac ‹⋀i. i ∈⇩∘ I ⟹ vsv (f ↾⇧l⇩∘ (A i))›)
subgoal by (insert assms(1), intro vsvI) (blast intro!: vsubset_antisym)+
subgoal using assms by blast
done
show "vsv ((f ↾⇧l⇩∘ ⋂⇩∘ ((λa∈⇩∘I. A a) `⇩∘ I))¯⇩∘)"
proof(intro vsvI)
fix a b c
assume ab: "⟨a, b⟩ ∈⇩∘ (f ↾⇧l⇩∘ ⋂⇩∘ ((λa∈⇩∘I. A a) `⇩∘ I))¯⇩∘"
and ac: "⟨a, c⟩ ∈⇩∘ (f ↾⇧l⇩∘ ⋂⇩∘ ((λa∈⇩∘I. A a) `⇩∘ I))¯⇩∘"
from assms(2) have hyp: "⋀i. i ∈⇩∘ I ⟹ vsv ((f ↾⇧l⇩∘ (A i))¯⇩∘)" by blast
from assms(1) obtain i where "i ∈⇩∘ I" and "⋂⇩∘ ((λa∈⇩∘I. A a) `⇩∘ I) ⊆⇩∘ A i"
by (auto intro!: vsubset_antisym)
with ab ac hyp ‹i ∈⇩∘ I› show "b = c" by auto
qed auto
qed
subsection‹Additional simplification rules for indexed families of sets.›
text‹Union.›
lemma vifunion_simps[simp]:
"⋀a B I. (⋃⇩∘i∈⇩∘I. vinsert a (B i)) =
(if I=0 then 0 else vinsert a (⋃⇩∘i∈⇩∘I. B i))"
"⋀A B I. (⋃⇩∘i∈⇩∘I. A i ∪⇩∘ B) = ((if I=0 then 0 else (⋃⇩∘i∈⇩∘I. A i) ∪⇩∘ B))"
"⋀A B I. (⋃⇩∘i∈⇩∘I. A ∪⇩∘ B i) = ((if I=0 then 0 else A ∪⇩∘ (⋃⇩∘i∈⇩∘I. B i)))"
"⋀A B I. (⋃⇩∘i∈⇩∘I. A i ∩⇩∘ B) = ((⋃⇩∘i∈⇩∘I. A i) ∩⇩∘ B)"
"⋀A B I. (⋃⇩∘i∈⇩∘I. A ∩⇩∘ B i) = (A ∩⇩∘ (⋃⇩∘i∈⇩∘I. B i))"
"⋀A B I. (⋃⇩∘i∈⇩∘I. A i -⇩∘ B) = ((⋃⇩∘i∈⇩∘I. A i) -⇩∘ B)"
"⋀A B. (⋃⇩∘i∈⇩∘⋃⇩∘A. B i) = (⋃⇩∘y∈⇩∘A. ⋃⇩∘i∈⇩∘y. B i)"
by
(
force
simp: vrange_VLambda vimage_VLambda_vrange_rep
intro!: vsubset_antisym
)+
lemma vifunion_simps_ext:
"⋀a B I. vinsert a (⋃⇩∘i∈⇩∘I. B i) =
(if I=0 then set {a} else (⋃⇩∘i∈⇩∘I. vinsert a (B i)))"
"⋀A B I. (⋃⇩∘i∈⇩∘I. A i) ∪⇩∘ B = (if I=0 then B else (⋃⇩∘i∈⇩∘I. A i ∪⇩∘ B))"
"⋀A B I. A ∪⇩∘ (⋃⇩∘i∈⇩∘I. B i) = (if I=0 then A else (⋃⇩∘i∈⇩∘I. A ∪⇩∘ B i))"
"⋀A B I. ((⋃⇩∘i∈⇩∘I. A i) ∩⇩∘ B) = (⋃⇩∘i∈⇩∘I. A i ∩⇩∘ B)"
"⋀A B I. ((⋃⇩∘i∈⇩∘I. A i) -⇩∘ B) = (⋃⇩∘i∈⇩∘I. A i -⇩∘ B)"
"⋀A B. (⋃⇩∘y∈⇩∘A. ⋃⇩∘i∈⇩∘y. B i) = (⋃⇩∘i∈⇩∘⋃⇩∘A. B i)"
by (auto simp: vrange_VLambda)
lemma vifunion_vball_vbex_simps[simp]:
"⋀A P. (∀a∈⇩∘⋃⇩∘A. P a) ⟷ (∀y∈⇩∘A. ∀a∈⇩∘y. P a)"
"⋀A P. (∃a∈⇩∘⋃⇩∘A. P a) ⟷ (∃y∈⇩∘A. ∃a∈⇩∘y. P a)"
using vball_vifunion vbex_vifunion by auto
text‹Intersection.›
lemma vifintersection_simps[simp]:
"⋀I A B. (⋂⇩∘i∈⇩∘I. A i ∩⇩∘ B) = (if I = 0 then 0 else (⋂⇩∘i∈⇩∘I. A i) ∩⇩∘ B)"
"⋀I A B. (⋂⇩∘i∈⇩∘I. A ∩⇩∘ B i) = (if I = 0 then 0 else A ∩⇩∘ (⋂⇩∘i∈⇩∘I. B i))"
"⋀I A B. (⋂⇩∘i∈⇩∘I. A i -⇩∘ B) = (if I = 0 then 0 else (⋂⇩∘i∈⇩∘I. A i) -⇩∘ B)"
"⋀I A B. (⋂⇩∘i∈⇩∘I. A -⇩∘ B i) = (if I = 0 then 0 else A -⇩∘ (⋃⇩∘i∈⇩∘I. B i))"
"⋀I a B.
(⋂⇩∘i∈⇩∘I. vinsert a (B i)) = (if I = 0 then 0 else vinsert a (⋂⇩∘i∈⇩∘I. B i))"
"⋀I A B. (⋂⇩∘i∈⇩∘I. A i ∪⇩∘ B) = (if I = 0 then 0 else ((⋂⇩∘i∈⇩∘I. A i) ∪⇩∘ B))"
"⋀I A B. (⋂⇩∘i∈⇩∘I. A ∪⇩∘ B i) = (if I = 0 then 0 else (A ∪⇩∘ (⋂⇩∘i∈⇩∘I. B i)))"
by force+
lemma vifintersection_simps_ext:
"⋀A B I. (⋂⇩∘i∈⇩∘I. A i) ∩⇩∘ B = (if I = 0 then 0 else (⋂⇩∘i∈⇩∘I. A i ∩⇩∘ B))"
"⋀A B I. A ∩⇩∘ (⋂⇩∘i∈⇩∘I. B i) = (if I = 0 then 0 else (⋂⇩∘i∈⇩∘I. A ∩⇩∘ B i))"
"⋀A B I. (⋂⇩∘i∈⇩∘I. A i) -⇩∘ B = (if I = 0 then 0 else (⋂⇩∘i∈⇩∘I. A i -⇩∘ B))"
"⋀A B I. A -⇩∘ (⋃⇩∘i∈⇩∘I. B i) = (if I = 0 then A else (⋂⇩∘i∈⇩∘I. A -⇩∘ B i))"
"⋀a B I. vinsert a (⋂⇩∘i∈⇩∘I. B i) =
(if I = 0 then set {a} else (⋂⇩∘i∈⇩∘I. vinsert a (B i)))"
"⋀A B I. ((⋂⇩∘i∈⇩∘I. A i) ∪⇩∘ B) = (if I = 0 then B else (⋂⇩∘i∈⇩∘I. A i ∪⇩∘ B))"
"⋀A B I. A ∪⇩∘ (⋂⇩∘i∈⇩∘I. B i) = (if I = 0 then A else (⋂⇩∘i∈⇩∘I. A ∪⇩∘ B i))"
using vifintersection_simps by auto
subsection‹Knowledge transfer: union and intersection of indexed families›
lemma SUP_vifunion: "(SUP ξ∈elts α. A ξ) = (⋃⇩∘ξ∈⇩∘α. A ξ)"
by (simp add: vimage_VLambda_vrange_rep vrange_VLambda)
lemma INF_vifintersection: "(INF ξ∈elts α. A ξ) = (⋂⇩∘ξ∈⇩∘α. A ξ)"
by (simp add: vimage_VLambda_vrange_rep vrange_VLambda)
lemmas Ord_induct3'[consumes 1, case_names 0 succ Limit, induct type: V] =
Ord_induct3[unfolded SUP_vifunion]
lemma Limit_vifunion_def[simp]:
assumes "Limit α"
shows "(⋃⇩∘ξ∈⇩∘α. ξ) = α"
using assms unfolding SUP_vifunion[symmetric] by simp
lemmas_with[unfolded SUP_vifunion INF_vifintersection]:
TC = ZFC_Cardinals.TC
and rank_Sup = ZFC_Cardinals.rank_Sup
and TC_def = ZFC_Cardinals.TC_def
and Ord_equality = ZFC_in_HOL.Ord_equality
and Aleph_Limit = ZFC_Cardinals.Aleph_Limit
and rank = ZFC_Cardinals.rank
and Vset = ZFC_in_HOL.Vset
and mult = Kirby.mult
and Aleph_def = ZFC_Cardinals.Aleph_def
and times_V_def = Kirby.times_V_def
and mult_Limit = Kirby.mult_Limit
and Vfrom = ZFC_in_HOL.Vfrom
and Vfrom_def = ZFC_in_HOL.Vfrom_def
and rank_def = ZFC_Cardinals.rank_def
and add_Limit = Kirby.add_Limit
and Limit_Vfrom_eq = ZFC_in_HOL.Limit_Vfrom_eq
and VSigma_def = ZFC_Cardinals.VSigma_def
and add_Sup_distrib_id = Kirby.add_Sup_distrib_id
and Limit_add_Sup_distrib = Kirby.Limit_add_Sup_distrib
and TC_mult = Kirby.TC_mult
and add_Sup_distrib = Kirby.add_Sup_distrib
subsection‹Disjoint union›
text‹
Fundamental properties have already been exposed in the main library
of ‹ZFC in HOL›.
›
syntax "_VPRODUCT" :: "pttrn ⇒ V ⇒ V ⇒ V" (‹(3∐⇩×_∈⇩∘_./ _)› [0, 0, 10] 10)
translations "∐⇩×i∈⇩∘I. A" ⇌ "CONST VSigma I (λi. A)"
text‹Further rules.›
lemma vdunion_expE[elim!]:
assumes "c ∈⇩∘ (⋃⇩∘i∈⇩∘I. ⋃⇩∘x∈⇩∘A i. set {⟨i, x⟩})"
obtains i a where "i ∈⇩∘ I" and "a ∈⇩∘ A i" and "c = ⟨i, a⟩"
using assms by (clarsimp simp: vrange_VLambda vimage_VLambda_vrange_rep)
lemma vdunion_def: "(∐⇩×i∈⇩∘I. A i) = (⋃⇩∘i∈⇩∘I. ⋃⇩∘x∈⇩∘A i. set {⟨i, x⟩})"
by (auto simp: vrange_VLambda vimage_VLambda_vrange_rep)
text‹Set operations.›
lemma vdunion_vsingleton: "(∐⇩×i∈⇩∘set{c}. A i) = set {c} ×⇩∘ A c" by auto
lemma vdunion_vdoubleton:
"(∐⇩×i∈⇩∘set{a, b}. A i) = set {a} ×⇩∘ A a ∪⇩∘ set {b} ×⇩∘ A b"
by auto
text‹Connections.›
lemma vdunion_vsum: "(∐⇩×i∈⇩∘set{0, 1}. if i=0 then A else B) = A ⨄ B"
unfolding vdunion_vdoubleton vsum_def by simp
subsection‹Infinite Cartesian product›
definition vproduct :: "V ⇒ (V ⇒ V) ⇒ V"
where "vproduct I A = set {f. vsv f ∧ 𝒟⇩∘ f = I ∧ (∀i∈⇩∘I. f⦇i⦈ ∈⇩∘ A i)}"
syntax "_VPRODUCT" :: "pttrn ⇒ V ⇒ V ⇒ V" (‹(3∏⇩∘_∈⇩∘_./ _)› [0, 0, 10] 10)
translations "∏⇩∘i∈⇩∘I. A" ⇌ "CONST vproduct I (λi. A)"
lemma small_vproduct[simp]:
"small {f. vsv f ∧ 𝒟⇩∘ f = I ∧ (∀i∈⇩∘I. f⦇i⦈ ∈⇩∘ A i)}"
(is ‹small ?A›)
proof-
from small_vsv[of I ‹(⋃⇩∘i∈⇩∘I. A i)›] have
"small {f. vsv f ∧ 𝒟⇩∘ f = I ∧ ℛ⇩∘ f ⊆⇩∘ (⋃⇩∘i∈⇩∘I. A i)}"
by simp
moreover have "?A ⊆ {f. vsv f ∧ 𝒟⇩∘ f = I ∧ ℛ⇩∘ f ⊆⇩∘ (⋃⇩∘i∈⇩∘I. A i)}"
proof(intro subsetI, unfold mem_Collect_eq, elim conjE, intro conjI)
fix f assume prems: "vsv f" "𝒟⇩∘ f = I" "∀i∈elts I. f⦇i⦈ ∈⇩∘ A i"
interpret vsv f by (rule prems(1))
show "ℛ⇩∘ f ⊆⇩∘ (⋃⇩∘i∈⇩∘I. A i)"
proof(intro vsubsetI)
fix y assume "y ∈⇩∘ ℛ⇩∘ f"
with prems(2) obtain i where y_def: "y = f⦇i⦈" and i: "i ∈⇩∘ I"
by (blast dest: vrange_atD)
from i prems(3) vifunionI show "y ∈⇩∘ (⋃⇩∘i∈⇩∘I. A i)"
unfolding y_def by auto
qed
qed
ultimately show ?thesis by (metis (lifting) smaller_than_small)
qed
text‹Rules.›
lemma vproductI[intro!]:
assumes "vsv f" and "𝒟⇩∘ f = I" and "∀i∈⇩∘I. f⦇i⦈ ∈⇩∘ A i"
shows "f ∈⇩∘ (∏⇩∘i∈⇩∘I. A i)"
using assms small_vproduct unfolding vproduct_def by auto
lemma vproductD[dest]:
assumes "f ∈⇩∘ (∏⇩∘i∈⇩∘I. A i)"
shows "vsv f"
and "𝒟⇩∘ f = I"
and "∀i∈⇩∘I. f⦇i⦈ ∈⇩∘ A i"
using assms unfolding vproduct_def by auto
lemma vproductE[elim!]:
assumes "f ∈⇩∘ (∏⇩∘i∈⇩∘I. A i)"
obtains "vsv f" and "𝒟⇩∘ f = I" and "∀i∈⇩∘I. f⦇i⦈ ∈⇩∘ A i"
using assms unfolding vproduct_def by auto
text‹Set operations.›
lemma vproduct_index_vempty[simp]: "(∏⇩∘i∈⇩∘0. A i) = set {0}"
proof-
have "{f. vsv f ∧ 𝒟⇩∘ f = 0 ∧ (∀i∈⇩∘0. f⦇i⦈ ∈⇩∘ A i)} = {0}"
using vbrelation.vlrestriction_vdomain vsv_eqI by fastforce
then show ?thesis unfolding vproduct_def by simp
qed
lemma vproduct_vsingletonI:
assumes "f⦇c⦈ ∈⇩∘ A c" and "f = set {⟨c, f⦇c⦈⟩}"
shows "f ∈⇩∘ (∏⇩∘i∈⇩∘set{c}. A i)"
using assms
apply(intro vproductI)
subgoal by (metis rel_vsingleton.vsv_axioms)
subgoal by (force intro!: vsubset_antisym)
subgoal by auto
done
lemma vproduct_vsingletonD:
assumes "f ∈⇩∘ (∏⇩∘i∈⇩∘set{c}. A i)"
shows "vsv f" and "f⦇c⦈ ∈⇩∘ A c" and "f = set {⟨c, f⦇c⦈⟩}"
proof-
from assms show "f = set {⟨c, f⦇c⦈⟩}"
by (elim vproductE) (metis VLambda_vsingleton vsv.vsv_is_VLambda)
qed (use assms in auto)
lemma vproduct_vsingletonE:
assumes "f ∈⇩∘ (∏⇩∘i∈⇩∘set{c}. A i)"
obtains "vsv f" and "f⦇c⦈ ∈⇩∘ A c" and "f = set {⟨c, f⦇c⦈⟩}"
using assms vproduct_vsingletonD that by auto
lemma vproduct_vsingleton_iff:
"f ∈⇩∘ (∏⇩∘i∈⇩∘set{c}. A i) ⟷ f⦇c⦈ ∈⇩∘ A c ∧ f = set {⟨c, f⦇c⦈⟩}"
by (rule iffI) (auto simp: vproduct_vsingletonD intro!: vproduct_vsingletonI)
lemma vproduct_vdoubletonI[intro]:
assumes "vsv f"
and "f⦇a⦈ ∈⇩∘ A a"
and "f⦇b⦈ ∈⇩∘ A b"
and "𝒟⇩∘ f = set {a, b}"
and "ℛ⇩∘ f ⊆⇩∘ A a ∪⇩∘ A b"
shows "f ∈⇩∘ (∏⇩∘i∈⇩∘set {a, b}. A i)"
using assms vifunion_vdoubleton by (intro vproductI) auto
lemma vproduct_vdoubletonD[dest]:
assumes "f ∈⇩∘ (∏⇩∘i∈⇩∘set{a, b}. A i)"
shows "vsv f"
and "f⦇a⦈ ∈⇩∘ A a"
and "f⦇b⦈ ∈⇩∘ A b"
and "𝒟⇩∘ f = set {a, b}"
and "f = set {⟨a, f⦇a⦈⟩, ⟨b, f⦇b⦈⟩}"
subgoal using assms by auto
subgoal using assms by auto
subgoal using assms by auto
subgoal using assms vifunion_vdoubleton by fastforce
subgoal by (metis assms VLambda_vdoubleton vproductE vsv.vsv_is_VLambda)
done
lemma vproduct_vdoubletonE:
assumes "f ∈⇩∘ (∏⇩∘i∈⇩∘set{a, b}. A i)"
obtains "vsv f"
and "f⦇a⦈ ∈⇩∘ A a"
and "f⦇b⦈ ∈⇩∘ A b"
and "𝒟⇩∘ f = set {a, b}"
and "f = set {⟨a, f⦇a⦈⟩, ⟨b, f⦇b⦈⟩}"
using assms vproduct_vdoubletonD that by simp
lemma vproduct_vdoubleton_iff:
"f ∈⇩∘ (∏⇩∘i∈⇩∘set {a, b}. A i) ⟷
vsv f ∧
f⦇a⦈ ∈⇩∘ A a ∧
f⦇b⦈ ∈⇩∘ A b ∧
𝒟⇩∘ f = set {a, b} ∧
f = set {⟨a, f⦇a⦈⟩, ⟨b, f⦇b⦈⟩}"
by (force elim!: vproduct_vdoubletonE)+
text‹Elementary properties.›
lemma vproduct_eq_vemptyI:
assumes "i ∈⇩∘ I" and "A i = 0"
shows "(∏⇩∘i∈⇩∘I. A i) = 0"
proof(intro vsubset_antisym vsubsetI)
fix x assume prems: "x ∈⇩∘ (∏⇩∘i∈⇩∘I. A i)"
from assms vproductD(3)[OF prems] show "x ∈⇩∘ 0" by auto
qed auto
lemma vproduct_eq_vemptyD:
assumes "(∏⇩∘i∈⇩∘I. A i) ≠ 0"
shows "⋀i. i ∈⇩∘ I ⟹ A i ≠ 0"
proof(rule ccontr, unfold not_not)
fix i assume prems: "i ∈⇩∘ I" "A i = 0"
with vproduct_eq_vemptyI[where A=A, OF prems] assms show False by simp
qed
lemma vproduct_vrange:
assumes "f ∈⇩∘ (∏⇩∘i∈⇩∘I. A i)"
shows "ℛ⇩∘ f ⊆⇩∘ (⋃⇩∘i∈⇩∘I. A i)"
proof(intro vsubsetI)
fix x assume prems: "x ∈⇩∘ ℛ⇩∘ f"
have vsv_f: "vsv f"
and dom_f: "𝒟⇩∘ f = I"
and fi: "⋀i. i ∈⇩∘ I ⟹ f⦇i⦈ ∈⇩∘ A i"
by (simp_all add: vproductD[OF assms, rule_format])
interpret f: vsv f by (rule vsv_f)
from prems dom_f obtain i where x_def: "x = f⦇i⦈" and i: "i ∈⇩∘ I"
by (auto elim: f.vrange_atE)
from i fi show "x ∈⇩∘ (⋃⇩∘i∈⇩∘I. A i)" unfolding x_def by (intro vifunionI) auto
qed
lemma vproduct_vsubset_VPow: "(∏⇩∘i∈⇩∘I. A i) ⊆⇩∘ VPow (I ×⇩∘ (⋃⇩∘i∈⇩∘I. A i))"
proof(intro vsubsetI)
fix f assume "f ∈⇩∘ (∏⇩∘i∈⇩∘I. A i)"
then have vsv: "vsv f"
and domain: "𝒟⇩∘ f = I"
and range: "∀i∈elts I. f⦇i⦈ ∈⇩∘ A i"
by auto
interpret f: vsv f by (rule vsv)
have "f ⊆⇩∘ I ×⇩∘ (⋃⇩∘i∈⇩∘I. A i)"
proof(intro vsubsetI)
fix x assume prems: "x ∈⇩∘ f"
then obtain a b where x_def: "x = ⟨a, b⟩" by (elim f.vbrelation_vinE)
with prems have "a ∈⇩∘ 𝒟⇩∘ f" and "b ∈⇩∘ ℛ⇩∘ f" by auto
with range domain prems show "x ∈⇩∘ I ×⇩∘ (⋃⇩∘i∈⇩∘I. A i)"
by (fastforce simp: x_def)
qed
then show "f ∈⇩∘ VPow (I ×⇩∘ (⋃⇩∘i∈⇩∘I. A i))" by simp
qed
lemma VLambda_in_vproduct:
assumes "⋀i. i ∈⇩∘ I ⟹ f i ∈⇩∘ A i"
shows "(λi∈⇩∘I. f i) ∈⇩∘ (∏⇩∘i∈⇩∘I. A i)"
using assms by (simp add: vproductI vsv.vsv_vrange_vsubset_vifunion_app)
lemma vproduct_cong:
assumes "⋀i. i ∈⇩∘ I ⟹ f i = g i"
shows "(∏⇩∘i∈⇩∘I. f i) = (∏⇩∘i∈⇩∘I. g i)"
proof-
have "(∏⇩∘i∈⇩∘I. f i) ⊆⇩∘ (∏⇩∘i∈⇩∘I. g i)" if "⋀i. i ∈⇩∘ I ⟹ f i = g i" for f g
proof(intro vsubsetI)
fix x assume "x ∈⇩∘ (∏⇩∘i∈⇩∘I. f i)"
note xD = vproductD[OF this]
interpret vsv x by (rule xD(1))
show "x ∈⇩∘ (∏⇩∘i∈⇩∘I. g i)"
by (metis xD(2,3) that VLambda_in_vproduct vsv_is_VLambda)
qed
with assms show ?thesis by (intro vsubset_antisym) auto
qed
lemma vproduct_ex_in_vproduct:
assumes "x ∈⇩∘ (∏⇩∘i∈⇩∘J. A i)" and "J ⊆⇩∘ I" and "⋀i. i ∈⇩∘ I ⟹ A i ≠ 0"
obtains X where "X ∈⇩∘ (∏⇩∘i∈⇩∘I. A i)" and "x = X ↾⇧l⇩∘ J"
proof-
define X where "X = (λi∈⇩∘I. if i ∈⇩∘ J then x⦇i⦈ else (SOME x. x ∈⇩∘ A i))"
have X: "X ∈⇩∘ (∏⇩∘i∈⇩∘I. A i)"
by (intro vproductI) (use assms in ‹auto simp: X_def›)
moreover have "x = X ↾⇧l⇩∘ J"
proof(rule vsv_eqI)
from assms(1) have [simp]: "𝒟⇩∘ x = J" by clarsimp
moreover from assms(2) have "𝒟⇩∘ (X ↾⇧l⇩∘ J) = J" unfolding X_def by fastforce
ultimately show "𝒟⇩∘ x = 𝒟⇩∘ (X ↾⇧l⇩∘ J)" by simp
show "x⦇i⦈ = (X ↾⇧l⇩∘ J)⦇i⦈" if "i ∈⇩∘ 𝒟⇩∘ x" for i
using that assms(2) unfolding X_def by auto
qed (use assms X in auto)
ultimately show ?thesis using that by simp
qed
lemma vproduct_vsingleton_def: "(∏⇩∘i∈⇩∘set {j}. A i) = (∏⇩∘i∈⇩∘set {j}. A j)"
by auto
lemma vprojection_in_VUnionI:
assumes "A ⊆⇩∘ (∏⇩∘i∈⇩∘I. F i)" and "f ∈⇩∘ A" and "i ∈⇩∘ I"
shows "f⦇i⦈ ∈⇩∘ ⋃⇩∘(⋃⇩∘(⋃⇩∘A))"
proof(intro VUnionI)
show "f ∈⇩∘ A" by (rule assms(2))
from assms(1,2) have "f ∈⇩∘ (∏⇩∘i∈⇩∘I. F i)" by auto
note f = vproductD[OF this, rule_format]
interpret vsv f rewrites "𝒟⇩∘ f = I" by (auto intro: f(1) simp: f(2))
show "⟨i, f⦇i⦈⟩ ∈⇩∘ f" by (meson assms(3) vsv_appE)
show "set {i, f⦇i⦈} ∈⇩∘ ⟨i, f⦇i⦈⟩" unfolding vpair_def by simp
qed simp
subsection‹Projection›
definition vprojection :: "V ⇒ (V ⇒ V) ⇒ V ⇒ V"
where "vprojection I A i = (λf∈⇩∘(∏⇩∘i∈⇩∘I. A i). f⦇i⦈)"
text‹Rules.›
mk_VLambda vprojection_def
|vsv vprojection_vsv[intro]|
|vdomain vprojection_vdomain[simp]|
|app vprojection_app[simp, intro]|
text‹Elementary results.›
lemma vprojection_vrange_vsubset:
assumes "i ∈⇩∘ I"
shows "ℛ⇩∘ (vprojection I A i) ⊆⇩∘ A i"
unfolding vprojection_def
proof(intro vrange_VLambda_vsubset)
fix f assume prems: "f ∈⇩∘ (∏⇩∘i∈⇩∘I. A i)"
show "f⦇i⦈ ∈⇩∘ A i" by (intro vproductD(3)[OF prems, rule_format] assms)
qed
lemma vprojection_vrange:
assumes "i ∈⇩∘ I" and "⋀j. j ∈⇩∘ I ⟹ A j ≠ 0"
shows "ℛ⇩∘ (vprojection I A i) = A i"
proof
(
intro
vsubset_antisym vprojection_vrange_vsubset vrange_VLambda_vsubset assms(1)
)
show "A i ⊆⇩∘ ℛ⇩∘ (vprojection I A i)"
proof(intro vsubsetI)
fix x assume prems: "x ∈⇩∘ A i"
obtain f
where f: "⋀x. x ∈⇩∘ set {A i | i. i ∈⇩∘ I} ⟹ x ≠ 0 ⟹ f⦇x⦈ ∈⇩∘ x"
and "vsv f"
using that by (rule Axiom_of_Choice)
define f' where "f' = (λj∈⇩∘I. if j = i then x else f⦇A j⦈)"
show "x ∈⇩∘ ℛ⇩∘ (vprojection I A i)"
unfolding vprojection_def
proof(rule rel_VLambda.vsv_vimageI2')
show "f' ∈⇩∘ 𝒟⇩∘ (λf∈⇩∘vproduct I A. f⦇i⦈)"
unfolding vdomain_VLambda
proof(intro vproductI, unfold Ball_def; (intro allI conjI impI)?)
fix j assume "j ∈⇩∘ I"
with prems assms(2) show "f'⦇j⦈ ∈⇩∘ A j"
unfolding f'_def by (cases ‹j = i›) (auto intro!: f)
qed (simp_all add: f'_def)
with assms(1) show "x = (λf∈⇩∘vproduct I A. f⦇i⦈)⦇f'⦈"
unfolding f'_def by simp
qed
qed
qed
subsection‹Cartesian power of a set›
definition vcpower :: "V ⇒ V ⇒ V" (infixr ‹^⇩×› 80)
where "A ^⇩× n = (∏⇩∘i∈⇩∘n. A)"
text‹Rules.›
lemma vcpowerI[intro]:
assumes "f ∈⇩∘ (∏⇩∘i∈⇩∘n. A)"
shows "f ∈⇩∘ (A ^⇩× n)"
using assms unfolding vcpower_def by auto
lemma vcpowerD[dest]:
assumes "f ∈⇩∘ (A ^⇩× n)"
shows "f ∈⇩∘ (∏⇩∘i∈⇩∘n. A)"
using assms unfolding vcpower_def by auto
lemma vcpowerE[elim]:
assumes "f ∈⇩∘ (A ^⇩× n)" and "f ∈⇩∘ (∏⇩∘i∈⇩∘n. A) ⟹ P"
shows P
using assms unfolding vcpower_def by auto
text‹Set operations.›
lemma vcpower_index_vempty[simp]: "A ^⇩× 0 = set {0}"
unfolding vcpower_def by (rule vproduct_index_vempty)
lemma vcpower_of_vempty:
assumes "n ≠ 0"
shows "0 ^⇩× n = 0"
using assms unfolding vcpower_def vproduct_def by simp
text‹Connections.›
lemma vcpower_vdomain:
assumes "f ∈⇩∘ (A ^⇩× n)"
shows "𝒟⇩∘ f = n"
using assms by auto
lemma vcpower_vrange:
assumes "f ∈⇩∘ (A ^⇩× n)"
shows "ℛ⇩∘ f ⊆⇩∘ A"
using assms by (intro vsubsetI; elim vcpowerE vproductE) auto
text‹\newpage›
end
Theory CZH_Sets_Equipollence
section‹Equipollence›
theory CZH_Sets_Equipollence
imports CZH_Sets_IF
begin
subsection‹Background›
text‹
The section presents an adaption of the existing framework ‹Equipollence›
in the main library of Isabelle/HOL to the type \<^typ>‹V›.
Some of content of this theory was ported directly (with amendments) from the
theory ‹HOL-Library.Equipollence› in the main library of Isabelle/HOL.
›
subsection‹‹veqpoll››
abbreviation veqpoll :: "V ⇒ V ⇒ bool" (infixl "≈⇩∘" 50)
where "A ≈⇩∘ B ≡ elts A ≈ elts B"
text‹Rules›
lemma (in v11) v11_veqpollI[intro]:
assumes "𝒟⇩∘ r = A" and "ℛ⇩∘ r = B"
shows "A ≈⇩∘ B"
unfolding eqpoll_def
proof(intro exI[of _ ‹λx. r⦇x⦈›] bij_betw_imageI)
from v11.v11_injective v11_axioms show "inj_on (app r) (elts A)"
unfolding assms[symmetric] by (intro inj_onI) blast
show "app r ` elts A = elts B" unfolding assms[symmetric] by force+
qed
lemmas v11_veqpollI[intro] = v11.v11_veqpollI
lemma v11_veqpollE[elim]:
assumes "A ≈⇩∘ B"
obtains f where "v11 f" and "𝒟⇩∘ f = A" and "ℛ⇩∘ f = B"
proof-
from assms obtain f where bij_f: "bij_betw f (elts A) (elts B)"
unfolding eqpoll_def by auto
then have "v11 (λa∈⇩∘A. f a)"
and "𝒟⇩∘ (λa∈⇩∘A. f a) = A"
and "ℛ⇩∘ (λa∈⇩∘A. f a) = B"
by (auto simp add: in_mono vrange_VLambda)
then show ?thesis using that by simp
qed
text‹Set operations.›
lemma veqpoll_vsingleton: "set {x} ≈⇩∘ set {y}"
by (simp add: singleton_eqpoll)
lemma veqpoll_vinsert:
assumes "A ≈⇩∘ B" and "a ∉⇩∘ A" and "b ∉⇩∘ B"
shows "vinsert a A ≈⇩∘ vinsert b B"
using assms by (simp add: insert_eqpoll_insert_iff)
lemma veqpoll_pair:
assumes "a ≠ b" and "c ≠ d"
shows "set {a, b} ≈⇩∘ set {c, d}"
using assms by (simp add: insert_eqpoll_cong)
lemma veqpoll_vpair:
assumes "a ≠ b" and "c ≠ d"
shows "⟨a, b⟩ ≈⇩∘ ⟨c, d⟩"
using assms
unfolding vpair_def
by (metis doubleton_eq_iff insert_absorb2 veqpoll_pair)
subsection‹‹vlepoll››
abbreviation vlepoll :: "V ⇒ V ⇒ bool" (infixl "≲⇩∘" 50)
where "A ≲⇩∘ B ≡ elts A ≲ elts B"
text‹Set operations.›
lemma vlepoll_vsubset:
assumes "A ⊆⇩∘ B"
shows "A ≲⇩∘ B"
using assms by (simp add: less_eq_V_def subset_imp_lepoll)
text‹Special properties.›
lemma vlepoll_singleton_vinsert: "set {x} ≲⇩∘ vinsert y A"
by (simp add: singleton_lepoll)
lemma vlepoll_vempty_iff[simp]: "A ≲⇩∘ 0 ⟷ A = 0" by (rule iffI) fastforce+
subsection‹‹vlespoll››
abbreviation vlesspoll :: "V ⇒ V ⇒ bool" (infixl ‹≺⇩∘› 50)
where "A ≺⇩∘ B ≡ elts A ≺ elts B"
lemma vlesspoll_def: "A ≺⇩∘ B = (A ≲⇩∘ B ∧ ~(A ≈⇩∘ B))" by (simp add: lesspoll_def)
text‹Rules.›
lemmas vlesspollI[intro] = vlesspoll_def[THEN iffD2]
lemmas vlesspollD[dest] = vlesspoll_def[THEN iffD1]
lemma vlesspollE[elim]:
assumes "A ≺⇩∘ B" and "A ≲⇩∘ B ⟹ ~(A ≈⇩∘ B) ⟹ P"
shows P
using assms by (simp add: vlesspoll_def)
lemma (in v11) v11_vlepollI[intro]:
assumes "𝒟⇩∘ r = A" and "ℛ⇩∘ r ⊆⇩∘ B"
shows "A ≲⇩∘ B"
unfolding lepoll_def
proof(intro exI[of _ ‹λx. r⦇x⦈›] conjI)
show "inj_on (app r) (elts A)"
using assms(1) v11.v11_injective v11_axioms by (intro inj_onI) blast
show "app r ` elts A ⊆ elts B"
by (intro subsetI) (metis assms(1,2) imageE rev_vsubsetD vdomain_atD)
qed
lemmas v11_vlepollI[intro] = v11.v11_vlepollI
lemma v11_vlepollE[elim]:
assumes "A ≲⇩∘ B"
obtains f where "v11 f" and "𝒟⇩∘ f = A" and "ℛ⇩∘ f ⊆⇩∘ B"
proof-
from assms obtain f where "inj_on f (elts A)" and "f ` elts A ⊆ elts B"
unfolding lepoll_def by auto
then have "v11 (λa∈⇩∘A. f a)"
and "𝒟⇩∘ (λa∈⇩∘A. f a) = A"
and "ℛ⇩∘ (λa∈⇩∘A. f a) ⊆⇩∘ B"
by (auto simp: in_mono vrange_VLambda)
then show ?thesis using that by simp
qed
text‹\newpage›
end
Theory CZH_Sets_Cardinality
section‹Cardinality›
theory CZH_Sets_Cardinality
imports
CZH_Sets_Nat
CZH_Sets_Equipollence
begin
subsection‹Background›
text‹
The section presents further results about the cardinality of terms of the type
\<^typ>‹V›. The emphasis of this work, however, is on the development of a theory of
finite sets internalized in the type \<^typ>‹V›.
Many of the results that are presented in this section were carried over
(with amendments) from the theory ‹Finite› in the main library of Isabelle/HOL.
›
declare One_nat_def[simp del]
subsection‹Cardinality of an arbitrary set›
text‹Elementary properties.›
lemma vcard_veqpoll: "vcard A = vcard B ⟷ A ≈⇩∘ B"
by (metis cardinal_cong cardinal_eqpoll eqpoll_sym eqpoll_trans)
lemma vcard_vlepoll: "vcard A ≤ vcard B ⟷ A ≲⇩∘ B"
proof
assume "vcard A ≤ vcard B"
moreover have "vcard A ≈⇩∘ A" by (rule cardinal_eqpoll)
moreover have "vcard B ≈⇩∘ B" by (rule cardinal_eqpoll)
ultimately show "A ≲⇩∘ B"
by (meson eqpoll_sym lepoll_trans1 lepoll_trans2 vlepoll_vsubset)
qed (simp add: lepoll_imp_Card_le)
lemma vcard_vempty: "vcard A = 0 ⟷ A = 0"
proof-
have vcard_A: "vcard A ≈⇩∘ A" by (simp add: cardinal_eqpoll)
then show ?thesis using eq0_iff eqpoll_iff_bijections by metis
qed
lemmas vcard_vemptyD = vcard_vempty[THEN iffD1]
and vcard_vemptyI = vcard_vempty[THEN iffD2]
lemma vcard_neq_vempty: "vcard A ≠ 0⇩ℕ ⟷ A ≠ 0⇩ℕ"
using vcard_vempty by auto
lemmas vcard_neq_vemptyD = vcard_neq_vempty[THEN iffD1]
and vcard_neq_vemptyI = vcard_neq_vempty[THEN iffD2]
text‹Set operations.›
lemma vcard_mono:
assumes "A ⊆⇩∘ B"
shows "vcard A ≤ vcard B"
using assms by (simp add: lepoll_imp_Card_le vlepoll_vsubset)
lemma vcard_vinsert_in[simp]:
assumes "a ∈⇩∘ A"
shows "vcard (vinsert a A) = vcard A"
using assms by (simp add: cardinal_cong insert_absorb)
lemma vcard_vintersection_left: "vcard (A ∩⇩∘ B) ≤ vcard A"
by (simp add: vcard_mono)
lemma vcard_vintersection_right: "vcard (A ∩⇩∘ B) ≤ vcard B"
by (simp add: vcard_mono)
lemma vcard_vunion:
assumes "vdisjnt A B"
shows "vcard (A ∪⇩∘ B) = vcard A ⊕ vcard B"
using assms by (rule vcard_disjoint_sup)
lemma vcard_vdiff[simp]: "vcard (A -⇩∘ B) ⊕ vcard (A ∩⇩∘ B) = vcard A"
proof-
have ABB: "vdisjnt (A -⇩∘ B) (A ∩⇩∘ B)" by auto
have "A -⇩∘ B ∪⇩∘ A ∩⇩∘ B = A" by auto
from vcard_vunion[OF ABB, unfolded this] show ?thesis ..
qed
lemma vcard_vdiff_vsubset:
assumes "B ⊆⇩∘ A"
shows "vcard (A -⇩∘ B) ⊕ vcard B = vcard A"
by (metis assms inf.absorb_iff2 vcard_vdiff)
text‹Connections.›
lemma (in vsv) vsv_vcard_vdomain: "vcard (𝒟⇩∘ r) = vcard r"
unfolding vcard_veqpoll
proof-
define f where "f x = ⟨x, r⦇x⦈⟩" for x
have "bij_betw f (elts (𝒟⇩∘ r)) (elts r)"
unfolding f_def bij_betw_def
proof(intro conjI inj_onI subset_antisym subsetI)
from vlrestriction_vdomain show
"x ∈⇩∘ r ⟹ x ∈ (λx. ⟨x, r⦇x⦈⟩) ` elts (𝒟⇩∘ r)"
for x
unfolding mem_Collect_eq by blast
qed (auto simp: image_def)
then show "𝒟⇩∘ r ≈⇩∘ r" unfolding eqpoll_def by auto
qed
text‹Special properties.›
lemma vcard_vunion_vintersection:
"vcard (A ∪⇩∘ B) ⊕ vcard (A ∩⇩∘ B) = vcard A ⊕ vcard B"
proof-
have AB_ABB: "A ∪⇩∘ B = B ∪⇩∘ (A -⇩∘ B)" by auto
have ABB: "vdisjnt B (A -⇩∘ B)" by auto
show ?thesis
unfolding vcard_vunion[OF ABB, folded AB_ABB] cadd_assoc vcard_vdiff
by (simp add: cadd_commute)
qed
subsection‹Finite sets›
abbreviation vfinite :: "V ⇒ bool"
where "vfinite A ≡ finite (elts A)"
lemma vfinite_def: "vfinite A ⟷ (∃n∈⇩∘ω. n ≈⇩∘ A)"
proof
assume "finite (elts A)"
then obtain n :: nat where eltsA: "elts A ≈ {..<n}"
by (simp add: eqpoll_iff_card)
have on: "ord_of_nat n = set (ord_of_nat ` {..<n})"
by (simp add: ord_of_nat_eq_initial[symmetric])
from eltsA have "elts A ≈ elts (ord_of_nat n)"
unfolding on by (simp add: inj_on_def)
moreover have "ord_of_nat n ∈⇩∘ ω" by (simp add: ω_def)
ultimately show "∃n∈⇩∘ω. n ≈⇩∘ A" by (auto intro: eqpoll_sym)
next
assume "∃n∈⇩∘ω. n ≈⇩∘ A"
then obtain n where "n ∈⇩∘ ω" and "n ≈⇩∘ A" by auto
with eqpoll_finite_iff show "finite (elts A)"
by (auto intro: finite_Ord_omega)
qed
text‹Rules.›
lemmas vfiniteI[intro!] = vfinite_def[THEN iffD2]
lemmas vfiniteD[dest!] = vfinite_def[THEN iffD1]
lemma vfiniteE1[elim!]:
assumes "vfinite A" and "∃n∈⇩∘ω. n ≈⇩∘ A ⟹ P"
shows P
using assms by auto
lemma vfiniteE2[elim]:
assumes "vfinite A"
obtains n where "n ∈⇩∘ ω" and "n ≈⇩∘ A"
using assms by auto
text‹Elementary properties.›
lemma veqpoll_omega_vcard[intro, simp]:
assumes "n ∈⇩∘ ω" and "n ≈⇩∘ A"
shows "vcard A = n"
using
nat_into_Card[OF assms(1), unfolded Card_def]
cardinal_cong[OF assms(2)]
by simp
lemma (in vsv) vfinite_vimage[intro]:
assumes "vfinite A"
shows "vfinite (r `⇩∘ A)"
proof-
have rA: "r `⇩∘ A = r `⇩∘ (𝒟⇩∘ r ∩⇩∘ A)" by fast
have DrA: "𝒟⇩∘ r ∩⇩∘ A ⊆⇩∘ 𝒟⇩∘ r" by simp
show ?thesis by (simp add: inf_V_def assms vimage_image[OF DrA, folded rA])
qed
lemmas [intro] = vsv.vfinite_vimage
lemma vfinite_veqpoll_trans:
assumes "vfinite A" and "A ≈⇩∘ B"
shows "vfinite B"
using assms by (simp add: eqpoll_finite_iff)
lemma vfinite_vlepoll_trans:
assumes "vfinite A" and "B ≲⇩∘ A"
shows "vfinite B"
by (meson assms eqpoll_finite_iff finite_lepoll_infinite lepoll_antisym)
lemma vfinite_vlesspoll_trans:
assumes "vfinite A" and "B ≺⇩∘ A"
shows "vfinite B"
using assms by (auto simp: vlesspoll_def vfinite_vlepoll_trans)
text‹Induction.›
lemma vfinite_induct[consumes 1, case_names vempty vinsert]:
assumes "vfinite F"
and "P 0"
and "⋀x F. ⟦vfinite F; x ∉⇩∘ F; P F⟧ ⟹ P (vinsert x F)"
shows "P F"
proof-
from assms(1) obtain n where n: "n ∈⇩∘ ω" and "n ≈⇩∘ F" by clarsimp
then obtain f'' where bij: "bij_betw f'' (elts n) (elts F)"
unfolding eqpoll_def by clarsimp
define f where "f = (λa∈⇩∘n. f'' a)"
interpret v11 f
unfolding f_def
proof(intro v11I)
show "vsv ((λa∈⇩∘n. f'' a)¯⇩∘)"
proof(intro vsvI)
fix a b c
assume "⟨a, b⟩ ∈⇩∘ (λa∈⇩∘n. f'' a)¯⇩∘" and "⟨a, c⟩ ∈⇩∘ (λa∈⇩∘n. f'' a)¯⇩∘"
then have "⟨b, a⟩ ∈⇩∘ (λa∈⇩∘n. f'' a)"
and "⟨c, a⟩ ∈⇩∘ (λa∈⇩∘n. f'' a)"
and "b ∈⇩∘ n"
and "c ∈⇩∘ n"
by auto
moreover then have "f'' b = f'' c" by auto
ultimately show "b = c" using bij by (metis bij_betw_iff_bijections)
qed auto
qed auto
have dom_f: "𝒟⇩∘ f = n" unfolding f_def by clarsimp
have ran_f: "ℛ⇩∘ f = F"
proof(intro vsubset_antisym vsubsetI)
fix b assume "b ∈⇩∘ ℛ⇩∘ f"
then obtain a where "a ∈⇩∘ n" and "b = f'' a" unfolding f_def by auto
then show "b ∈⇩∘ F" by (meson bij bij_betw_iff_bijections)
next
fix b assume "b ∈⇩∘ F"
then obtain a where "a ∈⇩∘ n" and "b = f'' a"
by (metis bij bij_betw_iff_bijections)
then show "b ∈⇩∘ ℛ⇩∘ f" unfolding f_def by auto
qed
define f' where "f' n = f `⇩∘ n" for n
have F_def: "F = f' n"
unfolding f'_def using dom_f ran_f vimage_vdomain by clarsimp
have "v11 (λa∈⇩∘n. f' a)"
proof(intro vsv.vsv_valneq_v11I, unfold vdomain_VLambda)
show "vsv (λa∈⇩∘n. f' a)" by simp
fix x y assume xD: "x ∈⇩∘ n" and yD: "y ∈⇩∘ n" and xy: "x ≠ y"
from ‹x ∈⇩∘ n› ‹y ∈⇩∘ n› ‹n ∈⇩∘ ω› have xn: "x ⊆⇩∘ n" and yn: "y ⊆⇩∘ n"
by (simp_all add: OrdmemD order.strict_implies_order)
show "(λa∈⇩∘n. f' a)⦇x⦈ ≠ (λa∈⇩∘n. f' a)⦇y⦈"
unfolding beta[OF xD] beta[OF yD] f'_def
using xn yn xy
by (simp add: dom_f v11_vimage_vpsubset_neq)
qed
define P' where "P' n' = (if n' ≤ n then P (f' n') else True)" for n'
from n have "P' n"
proof(induct rule: omega_induct)
case 0 then show ?case
unfolding P'_def f'_def using assms(2) by auto
next
case (succ k) show ?case
proof(cases ‹succ k ≤ n›)
case True
then obtain x where xF: "vinsert x (f' k) = (f' (succ k))"
by (simp add: f'_def succ_def vsubsetD dom_f vsv_vimage_vinsert)
from True have "k ≤ n" by auto
with ‹P' k› have "P (f' k)" unfolding P'_def by simp
then have "f' k ≠ f' (succ k)"
by (simp add: True f'_def ‹k ≤ n› dom_f v11_vimage_vpsubset_neq)
with xF have "x ∉⇩∘ f' k" by auto
have "vfinite (f' k)"
by (simp add: ‹k ∈⇩∘ ω› f'_def finite_Ord_omega vfinite_vimage)
from assms(3)[OF ‹vfinite (f' k)› ‹x ∉⇩∘ f' k› ‹P (f' k)›] show ?thesis
unfolding xF P'_def by simp
qed (unfold P'_def, auto)
qed
then show ?thesis unfolding P'_def F_def by simp
qed
text‹Set operations.›
lemma vfinite_vempty[simp]: "vfinite (0⇩ℕ)" by simp
lemma vfinite_vsingleton[simp]: "vfinite (set {x})" by simp
lemma vfinite_vdoubleton[simp]: "vfinite (set {x, y})" by simp
lemma vfinite_vinsert:
assumes "vfinite F"
shows "vfinite (vinsert x F)"
using assms by simp
lemma vfinite_vinsertD:
assumes "vfinite (vinsert x F)"
shows "vfinite F"
using assms by simp
lemma vfinite_vsubset:
assumes "vfinite B" and "A ⊆⇩∘ B"
shows "vfinite A"
using assms
by (induct arbitrary: A rule: vfinite_induct)
(simp_all add: less_eq_V_def finite_subset)
lemma vfinite_vunion: "vfinite (A ∪⇩∘ B) ⟷ vfinite A ∧ vfinite B"
by (auto simp: elts_sup_iff)
lemma vfinite_vunionI:
assumes "vfinite A" and "vfinite B"
shows "vfinite (A ∪⇩∘ B)"
using assms by (simp add: elts_sup_iff)
lemma vfinite_vunionD:
assumes "vfinite (A ∪⇩∘ B)"
shows "vfinite A" and "vfinite B"
using assms by (auto simp: elts_sup_iff)
lemma vfinite_vintersectionI:
assumes "vfinite A" and "vfinite B"
shows "vfinite (A ∩⇩∘ B)"
using assms by (simp add: vfinite_vsubset)
lemma vfinite_VPowI:
assumes "vfinite A"
shows "vfinite (VPow A)"
using assms
proof(induct rule: vfinite_induct)
case vempty then show ?case by simp
next
case (vinsert x F)
then show ?case
unfolding VPow_vinsert
using rel_VLambda.vfinite_vimage
by (intro vfinite_vunionI) metis+
qed
text‹Connections.›
lemma vfinite_vcard_vfinite: "vfinite (vcard A) = vfinite A"
by (simp add: cardinal_eqpoll eqpoll_finite_iff)
lemma vfinite_vcard_omega_iff: "vfinite A ⟷ vcard A ∈⇩∘ ω"
using vfinite_vcard_vfinite by auto
lemmas vcard_vfinite_omega = vfinite_vcard_omega_iff[THEN iffD2]
and vfinite_vcard_omega = vfinite_vcard_omega_iff[THEN iffD1]
lemma vfinite_csucc[intro, simp]:
assumes "vfinite A"
shows "csucc (vcard A) = succ (vcard A)"
using assms by (force simp: finite_csucc)
lemmas [intro, simp] = finite_csucc
text‹Previous connections.›
lemma vcard_vsingleton[simp]: "vcard (set {a}) = 1⇩ℕ" by auto
lemma vfinite_vcard_vinsert_nin[simp]:
assumes "vfinite A" and "a ∉⇩∘ A"
shows "vcard (vinsert a A) = csucc (vcard A)"
using assms by (simp add: ZFC_in_HOL.vinsert_def)
text‹\newpage›
end
Theory CZH_Sets_Ordinals
section‹Further results about ordinal numbers›
theory CZH_Sets_Ordinals
imports
CZH_Sets_Nat
CZH_Sets_IF
Complex_Main
begin
subsection‹Background›
text‹
The subsection presents several results about ordinal
numbers. The primary general reference for this section
is \cite{takeuti_introduction_1971}.
›
lemmas [intro] = Limit_is_Ord Ord_in_Ord
subsection‹Further ordinal arithmetic and inequalities›
lemma Ord_succ_mono:
assumes "Ord β" and "α ∈⇩∘ β"
shows "succ α ∈⇩∘ succ β"
proof-
from assms have "Ord α" by blast
from assms ‹Ord α› have "α < β" by (auto dest: Ord_mem_iff_lt)
from assms(1,2) this have "succ α < succ β"
by (meson assms ‹Ord α› Ord_linear2 Ord_succ leD le_succ_iff)
with assms(1) ‹Ord α› Ord_mem_iff_lt show "succ α ∈⇩∘ succ β" by blast
qed
lemma Limit_right_Limit_mult:
assumes "Ord α" and "Limit β" and "0 ∈⇩∘ α"
shows "Limit (α * β)"
proof-
have αβ: "α * β = (⋃⇩∘ξ∈⇩∘β. α * ξ)" by (rule mult_Limit[OF assms(2), of α])
from assms(1,2) Ord_mult have "Ord (α * β)" by blast
then show ?thesis
proof(cases rule: Ord_cases)
case (succ γ)
from succ(1) have "γ ∈⇩∘ α * β" unfolding succ(2)[symmetric] by simp
then obtain ξ where "ξ ∈⇩∘ β" and "γ ∈⇩∘ α * ξ" unfolding αβ by auto
moreover with assms(2) have "Ord ξ" by auto
ultimately have sγ_sαξ: "succ γ ∈⇩∘ succ (α * ξ)"
using assms(1) Ord_succ_mono by simp
from assms(2,3) have "succ (α * ξ) ⊆⇩∘ α * ξ + α"
unfolding succ_eq_add1 by force
with sγ_sαξ have "succ γ ∈⇩∘ α * succ ξ"
unfolding mult_succ[symmetric] by auto
moreover have "succ ξ ∈⇩∘ β"
by (simp add: succ_in_Limit_iff ‹ξ ∈⇩∘ β› assms(2))
ultimately have "succ γ ∈⇩∘ α * β" unfolding αβ by force
with succ(2) show ?thesis by simp
qed (use assms(2,3) in auto)
qed
lemma Limit_left_Limit_mult:
assumes "Limit α" and "Ord β" and "0 ∈⇩∘ β"
shows "Limit (α * β)"
proof(cases ‹Limit β›)
case False
then obtain β' where "Ord β'" and β_def: "β = succ β'"
by (metis Ord_cases assms(2,3) eq0_iff)
have α_sβ': "α * succ β' = α * β' + α" by (simp add: mult_succ)
from assms(1) have "Limit (α * β' + α)" by (simp add: Limit_is_Ord ‹Ord β'›)
then show "Limit (α * β)" unfolding β_def α_sβ' by simp
qed (use assms in ‹auto simp: Limit_def dest: Limit_right_Limit_mult›)
lemma zero_if_Limit_eq_Limit_plus_vnat:
assumes "Limit α" and "Limit β" and "α = β + n" and "n ∈⇩∘ ω"
shows "n = 0"
proof(rule ccontr)
assume prems: "n ≠ 0"
from assms(1,2,4) have "Ord α" and "Ord β" and "Ord 0" and "Ord n" by auto
have "0 ∈⇩∘ n" by (simp add: mem_0_Ord prems assms(4))
with assms(4) obtain m where n_def: "n = succ m" by (auto elim: omega_prev)
from assms(1,3) show False by (simp add: n_def plus_V_succ_right)
qed
lemma Ord_vsubset_closed:
assumes "Ord α" and "Ord γ" and "α ⊆⇩∘ β" and "β ∈⇩∘ γ"
shows "α ∈⇩∘ γ"
proof-
from assms have "Ord β" by auto
with assms show ?thesis by (simp add: Ord_mem_iff_lt)
qed
lemma
assumes "Ord α" and "Ord γ" and "α + β ∈⇩∘ γ"
shows Ord_plus_Ord_closed_augend: "α ∈⇩∘ γ"
and Ord_plus_Ord_closed_addend: "β ∈⇩∘ γ"
proof-
from assms have "α + β ∈⇩∘ α + γ" by (meson vsubsetD add_le_left)
from add_mem_right_cancel[THEN iffD1, OF this] show "β ∈⇩∘ γ" .
from assms have "α ⊆⇩∘ α + β" by simp
from Ord_vsubset_closed[OF assms(1,2) this assms(3)] show "α ∈⇩∘ γ" .
qed
lemma Ord_ex1_Limit_plus_in_omega:
assumes "Ord α" and "ω ⊆⇩∘ α"
shows "∃!β. ∃!n. n ∈⇩∘ ω ∧ Limit β ∧ α = β + n"
proof-
let ?A = ‹set {γ. Limit γ ∧ γ ⊆⇩∘ α}›
have small[simp]: "small {γ. Limit γ ∧ γ ⊆⇩∘ α}"
proof-
from Ord_mem_iff_lt have "{γ. Limit γ ∧ γ ⊆⇩∘ α} ⊆ elts (succ α)"
by (auto dest: order.not_eq_order_implies_strict intro: assms(1))
then show "small {γ. Limit γ ∧ γ ⊆⇩∘ α}" by (meson down)
qed
let ?β = ‹⋃⇩∘?A›
have "?β ⊆⇩∘ α" by auto
moreover have L_β: "Limit ?β"
proof(subst Limit_def, intro conjI allI impI)
show "Ord ?β" by (fastforce intro: Ord_Sup)
from assms(2) show "0 ∈⇩∘ ?β" by auto
fix y assume "y ∈⇩∘ ?β"
then obtain γ where "y ∈⇩∘ γ" and "γ ∈⇩∘ ?A" by clarsimp
then show "succ y ∈⇩∘ ?β" by (auto simp: succ_in_Limit_iff)
qed
ultimately obtain γ where "Ord γ" and α_def: "α = ?β + γ"
by (metis assms(1) le_Ord_diff Limit_is_Ord)
from L_β have L_βω: "Limit (?β + ω)" by (blast intro: Limit_add_Limit)
have "γ ⊂⇩∘ ω"
proof(rule ccontr)
assume "~γ ⊂⇩∘ ω"
with ‹Ord γ› Ord_linear2 have "ω ⊆⇩∘ γ" by auto
then obtain δ where γ_def: "γ = ω + δ"
by (blast dest: Ord_odiff_eq intro: ‹Ord γ›)
from α_def have "α = (?β + ω) + δ" by (simp add: add.assoc γ_def)
then have "?β + ω ⊆⇩∘ α" by (metis add_le_cancel_left0)
with L_βω have "?β + ω ⊆⇩∘ ?β" by auto
with add_le_cancel_left[of ?β ω 0, THEN iffD1] show False by simp
qed
with α_def have "γ ∈⇩∘ ω" by (auto simp: Ord_mem_iff_lt ‹Ord γ›)
show ?thesis
proof
(
intro ex1I conjI;
(elim conjE ex1E allE conjE impE | tactic‹all_tac›);
(intro conjI | tactic‹all_tac›)
)
show "γ ∈⇩∘ ω" by (rule ‹γ ∈⇩∘ ω›)
show "Limit ?β" by (rule ‹Limit ?β›)
show "α = ?β + γ" by (rule α_def)
from α_def show "α = ?β + n ⟹ n = γ" for n by auto
show "n ∈⇩∘ ω ⟹ Limit β ⟹ α = β + n ⟹ β = ?β" for n β
proof-
assume prems: "n ∈⇩∘ ω" "Limit β" "α = β + n"
from L_β prems(2,3) have "β ⊆⇩∘ ?β" by auto
then obtain η where β_def: "?β = β + η" and "Ord η"
by (metis (lifting) L_β Limit_is_Ord le_Ord_diff prems(2))
moreover have "η ∈⇩∘ ω"
proof-
from α_def β_def have "β + η + γ = β + n" by (simp add: prems(3))
then have "η + γ = n" by (simp add: add.assoc)
with ‹γ ∈⇩∘ ω› ‹n ∈⇩∘ ω› ‹Ord γ› show "η ∈⇩∘ ω"
by (blast intro: calculation(2) Ord_plus_Ord_closed_augend)
qed
ultimately show ?thesis
using prems(2) L_β by (force dest: zero_if_Limit_eq_Limit_plus_vnat)
qed
qed
qed
lemma not_Limit_if_in_Limit_plus_omega:
assumes "Limit α" and "α ∈⇩∘ β" and "β ∈⇩∘ α + ω"
shows "~Limit β"
proof-
from assms Ord_add have "Ord β" by blast
show ?thesis
using assms(3)
proof(cases rule: mem_plus_V_E)
case 1 with mem_not_sym show ?thesis by (auto simp: assms(2,3))
next
case (2 z)
from zero_if_Limit_eq_Limit_plus_vnat[OF _ assms(1) 2(2) 2(1)] 2(2) assms(2)
show ?thesis
by force
qed
qed
lemma Limit_plus_omega_vsubset_Limit:
assumes "Limit α" and "Limit β" and "α ∈⇩∘ β"
shows "α + ω ⊆⇩∘ β"
proof-
from assms(1) have Lαω: "Limit (α + ω)" by (simp add: Limit_is_Ord)
from not_Limit_if_in_Limit_plus_omega[OF assms(1,3)] assms(2) have
"β ∉⇩∘ α + ω"
by clarsimp
with assms(2) have "~β ⊂⇩∘ α + ω"
by (blast intro: Lαω dest: Ord_mem_iff_lt Limit_is_Ord)
then show "α + ω ⊆⇩∘ β" by (meson assms Lαω Limit_is_Ord Ord_linear2)
qed
lemma Limit_plus_nat_in_Limit:
assumes "Limit α" and "Limit β" and "α ∈⇩∘ β"
shows "α + a⇩ℕ ∈⇩∘ β"
using assms Limit_plus_omega_vsubset_Limit[OF assms] by auto
lemma omega2_vsubset_Limit:
assumes "Limit α" and "ω ∈⇩∘ α"
shows "ω + ω ⊆⇩∘ α"
using assms by (simp add: Limit_plus_omega_vsubset_Limit)
text‹\newpage›
end
Theory CZH_Sets_FSequences
section‹Finite sequences›
theory CZH_Sets_FSequences
imports CZH_Sets_Cardinality
begin
subsection‹Background›
text‹
The section presents a theory of finite sequences internalized in the
type \<^typ>‹V›. The content of this subsection
was inspired by and draws on many ideas from the content
of the theory ‹List› in the main library of Isabelle/HOL.
›
subsection‹Definition and common properties›
text‹
A finite sequence is defined as a single-valued binary relation whose domain
is an initial segment of the set of natural numbers.
›
locale vfsequence = vsv xs for xs +
assumes vfsequence_vdomain_in_omega: "𝒟⇩∘ xs ∈⇩∘ ω"
locale vfsequence_pair = r⇩1: vfsequence xs⇩1 + r⇩2: vfsequence xs⇩2 for xs⇩1 xs⇩2
text‹Rules.›
lemmas [intro] = vfsequence.axioms(1)
lemma vfsequenceI[intro]:
assumes "vsv xs" and "𝒟⇩∘ xs ∈⇩∘ ω"
shows "vfsequence xs"
using assms by (simp add: vfsequence.intro vfsequence_axioms_def)
lemma vfsequenceD[dest]:
assumes "vfsequence xs"
shows "𝒟⇩∘ xs ∈⇩∘ ω"
using assms vfsequence.vfsequence_vdomain_in_omega by simp
lemma vfsequenceE[elim]:
assumes "vfsequence xs" and "𝒟⇩∘ xs ∈⇩∘ ω ⟹ P"
shows P
using assms by auto
lemma vfsequence_iff: "vfsequence xs ⟷ vsv xs ∧ 𝒟⇩∘ xs ∈⇩∘ ω"
using vfsequence_def by auto
text‹Elementary properties.›
lemma (in vfsequence) vfsequence_vdomain: "𝒟⇩∘ xs = vcard xs"
unfolding vsv_vcard_vdomain[symmetric] using vfsequence_vdomain_in_omega by simp
lemma (in vfsequence) vfsequence_vcard_in_omega[simp]: "vcard xs ∈⇩∘ ω"
using vfsequence_vdomain_in_omega by (simp add: vfsequence_vdomain)
text‹Set operations.›
lemma vfsequence_vempty[intro, simp]: "vfsequence 0" by (simp add: vfsequenceI)
lemma vfsequence_vsingleton[intro, simp]: "vfsequence (set {⟨0, a⟩})"
using vone_in_omega
unfolding one_V_def
by (intro vfsequenceI) (auto simp: set_vzero_eq_ord_of_nat_vone)
lemma (in vfsequence) vfsequence_vinsert:
"vfsequence (vinsert ⟨vcard xs, a⟩ xs)"
using succ_def succ_in_omega by (auto simp: vfsequence_vdomain)
text‹Connections.›
lemma (in vfsequence) vfsequence_vfinite[simp]: "vfinite xs"
by (simp add: vfinite_vcard_omega_iff)
lemma (in vfsequence) vfsequence_vlrestriction[intro, simp]:
assumes "k ∈⇩∘ ω"
shows "vfsequence (xs ↾⇧l⇩∘ k)"
using assms by (force simp: vfsequence_vdomain vdomain_vlrestriction)
lemma vfsequence_vproduct:
assumes "n ∈⇩∘ ω" and "xs ∈⇩∘ (∏⇩∘i∈⇩∘n. A i)"
shows "vfsequence xs"
using assms by auto
lemma vfsequence_vcpower:
assumes "n ∈⇩∘ ω" and "xs ∈⇩∘ A ^⇩× n"
shows "vfsequence xs"
using assms vfsequence_vproduct by auto
text‹Special properties.›
lemma (in vfsequence) vfsequence_vdomain_vlrestriction[intro, simp]:
assumes "k ∈⇩∘ vcard xs"
shows "𝒟⇩∘ (xs ↾⇧l⇩∘ k) = k"
using assms
by
(
simp add:
OrdmemD
inf_absorb2
order.strict_implies_order
vdomain_vlrestriction
vfsequence_vdomain
)
lemma (in vfsequence) vfsequence_vlrestriction_vcard[simp]:
"xs ↾⇧l⇩∘ (vcard xs) = xs"
by (rule vlrestriction_vdomain[unfolded vfsequence_vdomain])
lemma vfsequence_vfinite_vcardI:
assumes "vsv xs" and "vfinite xs" and "𝒟⇩∘ xs = vcard xs"
shows "vfsequence xs"
using assms by (intro vfsequenceI) (auto simp: vfinite_vcard_omega)
lemma (in vfsequence) vfsequence_vrangeE:
assumes "a ∈⇩∘ ℛ⇩∘ xs"
obtains n where "n ∈⇩∘ vcard xs" and "xs⦇n⦈ = a"
using assms vfsequence_vdomain by auto
lemma (in vfsequence) vfsequence_vrange_vproduct:
assumes "⋀i. i ∈⇩∘ vcard xs ⟹ xs⦇i⦈ ∈⇩∘ A i"
shows "xs ∈⇩∘ (∏⇩∘i∈⇩∘vcard xs. A i)"
using vfsequence_vdomain vsv_axioms assms
by
(
intro vproductI;
(intro vsv.vsv_vrange_vsubset_vifunion_app | tactic‹all_tac›)
) auto
lemma (in vfsequence) vfsequence_vrange_vcpower:
assumes "ℛ⇩∘ xs ⊆⇩∘ A"
shows "xs ∈⇩∘ A ^⇩× (vcard xs)"
using assms
proof(elim vsubsetE; intro vcpowerI)
assume hyp: "x ∈⇩∘ ℛ⇩∘ xs ⟹ x ∈⇩∘ A" for x
from vfsequence_vdomain show "xs ∈⇩∘ (∏⇩∘i∈⇩∘vcard xs. A)"
by (intro vproductI) (blast intro: hyp elim: vdomain_atE)+
qed
text‹Alternative forms of existing results.›
lemmas [intro, simp] = vfsequence.vfsequence_vcard_in_omega
and [intro, simp] = vfsequence.vfsequence_vfinite
and [intro, simp] = vfsequence.vfsequence_vlrestriction
and [intro, simp] = vfsequence.vfsequence_vdomain_vlrestriction
and [intro, simp] = vfsequence.vfsequence_vlrestriction_vcard
subsection‹Appending an element to a finite sequence: ‹vcons››
subsubsection‹Definition and common properties›
definition vcons :: "V ⇒ V ⇒ V" (infixr ‹#⇩∘› 65)
where "xs #⇩∘ x = vinsert ⟨vcard xs, x⟩ xs"
text‹Syntax.›
abbreviation vempty_vfsequence (‹[]⇩∘›) where
"vempty_vfsequence ≡ 0::V"
notation vempty_vfsequence (‹[]⇩∘›)
nonterminal fsfields
nonterminal vlist
syntax
"" :: "V ⇒ fsfields" ("_")
"_fsfields" :: "fsfields ⇒ V ⇒ fsfields" ("_,/ _")
"_vlist" :: "fsfields ⇒ V" ("[(_)]⇩∘")
"_vapp" :: "V ⇒ fsfields ⇒ V" ("_ ⦇(_)⦈⇩∙" [100, 100] 100)
translations
"[xs, x]⇩∘" == "[xs]⇩∘ #⇩∘ x"
"[x]⇩∘" == "[]⇩∘ #⇩∘ x"
translations
"f⦇xs, x⦈⇩∙" == "f⦇[xs, x]⇩∘⦈"
"f⦇x⦈⇩∙" == "f⦇[x]⇩∘⦈"
text‹Rules.›
lemma vconsI[intro!]:
assumes "a ∈⇩∘ vinsert ⟨vcard xs, x⟩ xs"
shows "a ∈⇩∘ xs #⇩∘ x"
using assms unfolding vcons_def by clarsimp
lemma vconsD[dest!]:
assumes "a ∈⇩∘ xs #⇩∘ x"
shows "a ∈⇩∘ vinsert ⟨vcard xs, x⟩ xs"
using assms unfolding vcons_def by clarsimp
lemma vconsE[elim!]:
assumes "a ∈⇩∘ xs #⇩∘ x"
obtains a where "a ∈⇩∘ vinsert ⟨vcard xs, x⟩ xs"
using assms unfolding vcons_def by clarsimp
text‹Elementary properties.›
lemma vcons_neq_vempty[simp]: "ys #⇩∘ y ≠ []⇩∘" by auto
text‹Set operations.›
lemma vcons_vsingleton: "[a]⇩∘ = set {⟨0⇩ℕ, a⟩}" unfolding vcons_def by simp
lemma vcons_vdoubleton: "[a, b]⇩∘ = set {⟨0⇩ℕ, a⟩, ⟨1⇩ℕ, b⟩}"
unfolding vcons_def
using vinsert_vsingleton
by (force simp: vinsert_set_insert_eq)
lemma vcons_vsubset: "xs ⊆⇩∘ xs #⇩∘ x" by clarsimp
lemma vcons_vsubset':
assumes "vcons xs x ⊆⇩∘ ys"
shows "vcons xs x ⊆⇩∘ vcons ys y"
using assms unfolding vcons_def by auto
text‹Connections.›
lemma (in vfsequence) vfsequence_vcons[intro, simp]: "vfsequence (xs #⇩∘ x)"
proof(intro vfsequenceI)
from vfsequence_vdomain_in_omega vsv_vcard_vdomain have "vcard xs = 𝒟⇩∘ xs"
by (simp add: vcard_veqpoll)
show "vsv (xs #⇩∘ x)"
proof(intro vsvI)
fix a b c assume ab: "⟨a, b⟩ ∈⇩∘ xs #⇩∘ x" and ac: "⟨a, c⟩ ∈⇩∘ xs #⇩∘ x"
then consider (dom) "a ∈⇩∘ 𝒟⇩∘ xs" | (ndom) "a = vcard xs"
unfolding vcons_def by auto
then show "b = c"
proof cases
case dom
with ab have "⟨a, b⟩ ∈⇩∘ xs"
unfolding vcons_def by (auto simp: ‹vcard xs = 𝒟⇩∘ xs›)
moreover from dom ac have "⟨a, c⟩ ∈⇩∘ xs"
unfolding vcons_def by (auto simp: ‹vcard xs = 𝒟⇩∘ xs›)
ultimately show ?thesis using vsv by simp
next
case ndom
from ab have "⟨a, b⟩ = ⟨vcard xs, x⟩"
unfolding ndom vcons_def using ‹vcard xs = 𝒟⇩∘ xs› mem_not_refl by blast
moreover from ac have "⟨a, c⟩ = ⟨vcard xs, x⟩"
unfolding ndom vcons_def using ‹vcard xs = 𝒟⇩∘ xs› mem_not_refl by blast
ultimately show ?thesis by simp
qed
next
show "vbrelation (xs #⇩∘ x)" unfolding vcons_def
using vbrelation_vinsertI by auto
qed
show "𝒟⇩∘ (xs #⇩∘ x) ∈⇩∘ ω"
unfolding vcons_def
using succ_in_omega
by (auto simp: vfsequence_vdomain_in_omega succ_def ‹vcard xs = 𝒟⇩∘ xs›)
qed
lemma (in vfsequence) vfsequence_vcons_vdomain[simp]:
"𝒟⇩∘ (xs #⇩∘ x) = succ (vcard xs)"
by (simp add: succ_def vcons_def vfsequence_vdomain)
lemma (in vfsequence) vfsequence_vcons_vrange[simp]:
"ℛ⇩∘ (xs #⇩∘ x) = vinsert x (ℛ⇩∘ xs)"
by (simp add: vcons_def)
lemma (in vfsequence) vfsequence_vrange_vconsI:
assumes "ℛ⇩∘ xs ⊆⇩∘ X" and "x ∈⇩∘ X"
shows "ℛ⇩∘ (xs #⇩∘ x) ⊆⇩∘ X"
using assms unfolding vcons_def by auto
lemmas vfsequence_vrange_vconsI = vfsequence.vfsequence_vrange_vconsI[rotated 1]
text‹Special properties.›
lemma vcons_vrange_mono:
assumes "xs ⊆⇩∘ ys"
shows "ℛ⇩∘ (xs #⇩∘ x) ⊆⇩∘ ℛ⇩∘ (ys #⇩∘ x)"
using assms
unfolding vcons_def
by (simp add: vrange_mono vsubset_vinsert_leftI vsubset_vinsert_rightI)
lemma (in vfsequence) vfsequence_vlrestriction_succ:
assumes [simp]: "k ∈⇩∘ vcard xs"
shows "xs ↾⇧l⇩∘ succ k = xs ↾⇧l⇩∘ k #⇩∘ (xs⦇k⦈)"
proof-
interpret vlr: vfsequence ‹xs ↾⇧l⇩∘ k›
using assms by (blast intro: vfsequence_vcard_in_omega Ord_trans)
from vlr.vfsequence_vdomain[symmetric, simplified] show ?thesis
by
(
simp add:
vcons_def succ_def vfsequence_vdomain vsv_vlrestriction_vinsert
)
qed
lemma (in vfsequence) vfsequence_vremove_vcons_vfsequence:
assumes "xs = xs' #⇩∘ x"
shows "vfsequence xs'"
proof(cases‹⟨vcard xs', x⟩ ∈⇩∘ xs'›)
case True
with assms[unfolded vcons_def] have "xs = xs'" by auto
then show ?thesis using vfsequence_axioms by simp
next
case False
note x_def[simp] = assms[unfolded vcons_def]
interpret xs': vsv xs' using vsv_axioms by (auto intro: vsv_vinsertD)
have fin: "vfinite xs'" using vfsequence_vfinite by auto
have vcard_xs: "vcard xs = succ (vcard xs')" by (simp add: fin False)
have [simp]: "vcard xs' ∉⇩∘ 𝒟⇩∘ xs'" using False vsv_axioms by auto
have "vcard xs' ∈⇩∘ ω" using fin vfinite_vcard_omega by auto
have xs'_def: "xs' = xs ↾⇧l⇩∘ (vcard xs')"
using vcard_xs fin vfsequence_vdomain
by (auto simp: vinsert_ident succ_def)
from vfsequence_vlrestriction[OF ‹vcard xs' ∈⇩∘ ω›] show ?thesis
unfolding xs'_def[symmetric] .
qed
lemma (in vfsequence) vfsequence_vcons_ex:
assumes "xs ≠ []⇩∘"
obtains xs' x where "xs = xs' #⇩∘ x" and "vfsequence xs'"
proof-
from vcard_vempty have "0 ∈⇩∘ vcard xs" by (simp add: assms mem_0_Ord)
then obtain k where succk: "succ k = vcard xs"
by (metis omega_prev vfsequence_vcard_in_omega)
then have "k ∈⇩∘ vcard xs" using elts_succ by blast
from vfsequence_vlrestriction_succ[OF this, unfolded succk] show ?thesis
by (simp add: vfsequence_vremove_vcons_vfsequence that)
qed
subsubsection‹Induction and case analysis›
lemma vfsequence_induct[consumes 1, case_names 0 vcons]:
assumes "vfsequence xs"
and "P []⇩∘"
and "⋀xs x. ⟦vfsequence xs; P xs⟧ ⟹ P (xs #⇩∘ x)"
shows "P xs"
proof-
interpret vfsequence xs by (rule assms(1))
from assms(1) obtain n where "n ∈⇩∘ ω" and "𝒟⇩∘ xs = n" by auto
then have "n ≤ 𝒟⇩∘ xs" by auto
define P' where "P' k = P (xs ↾⇧l⇩∘ k)" for k
from ‹n ∈⇩∘ ω› and ‹n ≤ 𝒟⇩∘ xs› have "P' n"
proof(induction rule: omega_induct)
case (succ n') then show ?case
proof-
interpret vlr: vfsequence ‹xs ↾⇧l⇩∘ n'› by (simp add: succ.hyps)
have "P' n'" using succ.prems by (force intro: succ.IH)
then have "P (xs ↾⇧l⇩∘ n')" unfolding P'_def by assumption
have "n' ∈⇩∘ vcard xs"
using succ.prems by (auto simp: vsubset_iff vfsequence_vdomain)
from vfsequence_vlrestriction_succ[OF ‹n' ∈⇩∘ vcard xs›]
show "P' (succ n')"
by (simp add: P'_def ‹P (xs ↾⇧l⇩∘ n')› assms(3) vlr.vfsequence_axioms)
qed
qed (simp add: P'_def assms(2))
then show ?thesis unfolding P'_def ‹𝒟⇩∘ xs = n›[symmetric] by simp
qed
lemma vfsequence_cases[consumes 1, case_names 0 vcons]:
assumes "vfsequence xs"
and "xs = []⇩∘ ⟹ P"
and "⋀xs' x. ⟦xs = xs' #⇩∘ x; vfsequence xs'⟧ ⟹ P"
shows P
proof-
interpret vfsequence xs by (rule assms(1))
show ?thesis
proof(cases ‹xs = 0›)
case False
then obtain xs' x where "xs = xs' #⇩∘ x"
by (blast intro: vfsequence_vcons_ex)
then show ?thesis by (auto simp: assms(3) intro: vfsequence_vcons_ex)
qed (use assms(2) in auto)
qed
subsubsection‹Evaluation›
lemma (in vfsequence) vfsequence_vcard_vcons[simp]:
"vcard (xs #⇩∘ x) = succ (vcard xs)"
proof-
interpret xsx: vfsequence ‹xs #⇩∘ x› by simp
have "vcard (xs #⇩∘ x) = 𝒟⇩∘ (xs #⇩∘ x)"
by (rule xsx.vfsequence_vdomain[symmetric])
then show ?thesis
by (subst vcons_def) (simp add: succ_def vcons_def vfsequence_vdomain)
qed
lemma (in vfsequence) vfsequence_at_last[intro, simp]:
assumes "i = vcard xs"
shows "(xs #⇩∘ x)⦇i⦈ = x"
by (simp add: vfsequence_vdomain vcons_def assms)
lemma (in vfsequence) vfsequence_at_not_last[intro, simp]:
assumes "i ∈⇩∘ vcard xs"
shows "(xs #⇩∘ x)⦇i⦈ = xs⦇i⦈"
proof-
from assms have [simp]: "𝒟⇩∘ xs = vcard xs" by (auto simp: vfsequence_vdomain)
from assms have "i ∈⇩∘ 𝒟⇩∘ xs" by simp
moreover have "i ≠ vcard xs" using assms mem_not_refl by blast
ultimately show ?thesis
unfolding vcons_def using vsv.vsv_vinsert vsvE vsv_axioms by auto
qed
text‹Alternative forms of existing results.›
lemmas [intro, simp] = vfsequence.vfsequence_vcons
and [intro, simp] = vfsequence.vfsequence_vcard_vcons
and [intro, simp] = vfsequence.vfsequence_at_last
and [intro, simp] = vfsequence.vfsequence_at_not_last
and [intro, simp] = vfsequence.vfsequence_vcons_vdomain
and [intro, simp] = vfsequence.vfsequence_vcons_vrange
subsubsection‹Congruence-like properties›
context vfsequence_pair
begin
lemma vcons_eq_vcard_eq:
assumes "xs⇩1 #⇩∘ x⇩1 = xs⇩2 #⇩∘ x⇩2"
shows "vcard xs⇩1 = vcard xs⇩2"
by
(
metis
assms
succ_inject_iff
vfsequence.vfsequence_vcons_vdomain
r⇩1.vfsequence_axioms
r⇩2.vfsequence_axioms
)
lemma vcons_eqD[dest]:
assumes "xs⇩1 #⇩∘ x⇩1 = xs⇩2 #⇩∘ x⇩2"
shows "xs⇩1 = xs⇩2" and "x⇩1 = x⇩2"
proof-
have xsx1_last: "(xs⇩1 #⇩∘ x⇩1)⦇vcard xs⇩1⦈ = x⇩1" by simp
have xsx2_last: "(xs⇩2 #⇩∘ x⇩2)⦇vcard xs⇩2⦈ = x⇩2" by simp
from assms have vcard: "vcard xs⇩1 = vcard xs⇩2" by (rule vcons_eq_vcard_eq)
from trans[OF xsx1_last xsx1_last[unfolded vcard assms, symmetric]]
show "x⇩1 = x⇩2" unfolding xsx1_last xsx2_last .
have nxs1: "⟨vcard xs⇩1, x⇩1⟩ ∉⇩∘ xs⇩1"
using mem_not_refl r⇩1.vfsequence_vdomain by blast
have nxs2: "⟨vcard xs⇩2, x⇩2⟩ ∉⇩∘ xs⇩2"
using mem_not_refl r⇩2.vfsequence_vdomain by blast
have xsx1_xsx2: "⟨vcard xs⇩1, x⇩1⟩ = ⟨vcard xs⇩2, x⇩2⟩"
unfolding vcons_eq_vcard_eq[OF assms(1)] ‹x⇩1 = x⇩2› by simp
show "xs⇩1 = xs⇩2"
proof(rule vinsert_identD[OF _ nxs1])
from assms(1)[unfolded vcons_def] show
"vinsert ⟨vcard xs⇩1, x⇩1⟩ xs⇩1 = vinsert ⟨vcard xs⇩1, x⇩1⟩ xs⇩2"
by (auto simp: xsx1_xsx2)
show "⟨vcard xs⇩1, x⇩1⟩ ∉⇩∘ xs⇩2"
by (rule nxs2[folded ‹x⇩1 = x⇩2› vcons_eq_vcard_eq[OF assms(1)]])
qed
qed
lemma vcons_eqI:
assumes "xs⇩1 = xs⇩2" and "x⇩1 = x⇩2"
shows "xs⇩1 #⇩∘ x⇩1 = xs⇩2 #⇩∘ x⇩2"
using assms by (rule arg_cong2)
lemma vcons_eq_iff[simp]: "(xs⇩1 #⇩∘ x⇩1 = xs⇩2 #⇩∘ x⇩2) ⟷ (xs⇩1 = xs⇩2 ∧ x⇩1 = x⇩2)"
by auto
end
text‹Alternative forms of existing results.›
context
fixes xs⇩1 xs⇩2
assumes xs⇩1: "vfsequence xs⇩1"
and xs⇩2: "vfsequence xs⇩2"
begin
lemmas_with[OF vfsequence_pair.intro[OF xs⇩1 xs⇩2]]:
vcons_eqD' = vfsequence_pair.vcons_eqD
and vcons_eq_iff[intro, simp] = vfsequence_pair.vcons_eq_iff
end
lemmas vcons_eqD[dest] = vcons_eqD'[rotated -1]
subsection‹Transfer between the type \<^typ>‹V list› and finite sequences›
subsubsection‹Initialization›
primrec vfsequence_of_vlist :: "V list ⇒ V"
where
"vfsequence_of_vlist [] = 0"
| "vfsequence_of_vlist (x # xs) = vfsequence_of_vlist xs #⇩∘ x"
definition vlist_of_vfsequence :: "V ⇒ V list"
where "vlist_of_vfsequence = inv_into UNIV vfsequence_of_vlist"
lemma vfsequence_vfsequence_of_vlist: "vfsequence (vfsequence_of_vlist xs)"
by (induction xs) auto
lemma inj_vfsequence_of_vlist: "inj vfsequence_of_vlist"
proof
show "vfsequence_of_vlist x = vfsequence_of_vlist y ⟹ x = y"
for x y
proof(induction y arbitrary: x)
case Nil then show ?case by (cases x) auto
next
case (Cons a ys)
note Cons' = Cons
show ?case
proof(cases x)
case Nil with Cons show ?thesis by auto
next
case (Cons b zs)
from Cons'[unfolded Cons vfsequence_of_vlist.simps] have
"vfsequence_of_vlist zs #⇩∘ b = vfsequence_of_vlist ys #⇩∘ a"
by simp
then have "vfsequence_of_vlist zs = vfsequence_of_vlist ys" and "b = a"
by (auto simp: vfsequence_vfsequence_of_vlist)
from Cons'(1)[OF this(1)] this(2) show ?thesis unfolding Cons by auto
qed
qed
qed
lemma range_vfsequence_of_vlist:
"range vfsequence_of_vlist = {xs. vfsequence xs}"
proof(intro subset_antisym subsetI; unfold mem_Collect_eq)
show "xs ∈ range vfsequence_of_vlist ⟹ vfsequence xs" for xs
by (clarsimp simp: vfsequence_vfsequence_of_vlist)
fix xs assume "vfsequence xs"
then show "xs ∈ range vfsequence_of_vlist"
proof(induction rule: vfsequence_induct)
case 0 then show ?case
by (metis image_iff iso_tuple_UNIV_I vfsequence_of_vlist.simps(1))
next
case (vcons xs x) then show ?case
by (metis rangeE rangeI vfsequence_of_vlist.simps(2))
qed
qed
lemma vlist_of_vfsequence_vfsequence_of_vlist[simp]:
"vlist_of_vfsequence (vfsequence_of_vlist xs) = xs"
by (simp add: inj_vfsequence_of_vlist vlist_of_vfsequence_def)
lemma (in vfsequence) vfsequence_of_vlist_vlist_of_vfsequence[simp]:
"vfsequence_of_vlist (vlist_of_vfsequence xs) = xs"
using vfsequence_axioms range_vfsequence_of_vlist inj_vfsequence_of_vlist
by (simp add: f_inv_into_f vlist_of_vfsequence_def)
lemmas vfsequence_of_vlist_vlist_of_vfsequence[intro, simp] =
vfsequence.vfsequence_of_vlist_vlist_of_vfsequence
lemma vlist_of_vfsequence_vempty[simp]: "vlist_of_vfsequence []⇩∘ = []"
by
(
metis
vfsequence_of_vlist.simps(1)
vlist_of_vfsequence_vfsequence_of_vlist
)
text‹Transfer relation 1.›
definition cr_vfsequence :: "V ⇒ V list ⇒ bool"
where "cr_vfsequence a b ⟷ (a = vfsequence_of_vlist b)"
lemma cr_vfsequence_right_total[transfer_rule]: "right_total cr_vfsequence"
unfolding cr_vfsequence_def right_total_def by simp
lemma cr_vfsequence_bi_unqie[transfer_rule]: "bi_unique cr_vfsequence"
unfolding cr_vfsequence_def bi_unique_def
by (simp add: inj_eq inj_vfsequence_of_vlist)
lemma cr_vfsequence_transfer_domain_rule[transfer_domain_rule]:
"Domainp cr_vfsequence = (λxs. vfsequence xs)"
unfolding cr_vfsequence_def
proof(intro HOL.ext, rule iffI)
fix xs assume prems: "vfsequence xs"
interpret vfsequence xs by (rule prems)
have "∃ys. xs = vfsequence_of_vlist ys"
using prems
proof(induction rule: vfsequence_induct)
show "⟦ vfsequence xs; ∃ys. xs = vfsequence_of_vlist ys ⟧ ⟹
∃ys. xs #⇩∘ x = vfsequence_of_vlist ys"
for xs x
unfolding vfsequence_of_vlist_def by (metis list.simps(7))
qed auto
then show "Domainp (λa b. a = vfsequence_of_vlist b) xs" by auto
qed (clarsimp simp: vfsequence_vfsequence_of_vlist)
lemma cr_vfsequence_vconsD:
assumes "cr_vfsequence (xs #⇩∘ x) (y # ys)"
shows "cr_vfsequence xs ys" and "x = y"
proof-
from assms[unfolded cr_vfsequence_def] have xs_x_def:
"xs #⇩∘ x = vfsequence_of_vlist (y # ys)" .
then have xs_x: "vfsequence (xs #⇩∘ x)"
by (simp add: vfsequence_vfsequence_of_vlist)
interpret vfsequence xs
by (blast intro: vfsequence.vfsequence_vremove_vcons_vfsequence xs_x)
from
assms[unfolded cr_vfsequence_def vfsequence_of_vlist.simps(2)]
vfsequence_axioms
show "cr_vfsequence xs ys" and "x = y"
unfolding cr_vfsequence_def by (auto simp: vfsequence_vfsequence_of_vlist)
qed
text‹Transfer relation 2.›
definition cr_cr_vfsequence :: "V ⇒ V list list ⇒ bool"
where "cr_cr_vfsequence a b ⟷
(a = vfsequence_of_vlist (map vfsequence_of_vlist b))"
lemma cr_cr_vfsequence_right_total[transfer_rule]:
"right_total cr_cr_vfsequence"
unfolding cr_cr_vfsequence_def right_total_def by simp
lemma cr_cr_vfsequence_bi_unqie[transfer_rule]: "bi_unique cr_cr_vfsequence"
unfolding cr_cr_vfsequence_def bi_unique_def
by (simp add: inj_eq inj_vfsequence_of_vlist)
text‹Transfer relation for scalars.›
definition cr_scalar :: "(V ⇒ 'a ⇒ bool) ⇒ V ⇒ 'a ⇒ bool"
where "cr_scalar R x y = (∃a. x = [a]⇩∘ ∧ R a y)"
lemma cr_scalar_bi_unique[transfer_rule]:
assumes "bi_unique R"
shows "bi_unique (cr_scalar R)"
using assms unfolding cr_scalar_def bi_unique_def by auto
lemma cr_scalar_right_total[transfer_rule]:
assumes "right_total R"
shows "right_total (cr_scalar R)"
using assms unfolding cr_scalar_def right_total_def by simp
lemma cr_scalar_transfer_domain_rule[transfer_domain_rule]:
"Domainp (cr_scalar R) = (λx. ∃a. x = [a]⇩∘ ∧ Domainp R a)"
unfolding cr_scalar_def by auto
subsubsection‹Transfer rules for previously defined entities›
context
includes lifting_syntax
begin
lemma vfsequence_vempty_transfer[transfer_rule]: "cr_vfsequence []⇩∘ []"
unfolding cr_vfsequence_def by simp
lemma vfsequence_vempty_ll_transfer[transfer_rule]:
"cr_cr_vfsequence [[]⇩∘]⇩∘ [[]]"
unfolding cr_cr_vfsequence_def by simp
lemma vcons_transfer[transfer_rule]:
"((=) ===> cr_vfsequence ===> cr_vfsequence) (λx xs. xs #⇩∘ x) (λx xs. x # xs)"
by (intro rel_funI) (simp add: cr_vfsequence_def)
lemma vcons_ll_transfer[transfer_rule]:
"(cr_vfsequence ===> cr_cr_vfsequence ===> cr_cr_vfsequence)
(λx xs. xs #⇩∘ x) (λx xs. x # xs)"
by (intro rel_funI) (simp add: cr_vfsequence_def cr_cr_vfsequence_def)
lemma vfsequence_vrange_transfer[transfer_rule]:
"(cr_vfsequence ===> (=)) (λxs. elts (ℛ⇩∘ xs)) list.set"
proof(intro rel_funI)
fix xs ys assume prems: "cr_vfsequence xs ys"
then have "xs = vfsequence_of_vlist ys" unfolding cr_vfsequence_def by simp
then have "vfsequence xs" by (simp add: vfsequence_vfsequence_of_vlist)
from this prems show "elts (ℛ⇩∘ xs) = list.set ys"
proof(induction ys arbitrary: xs)
case (Cons a ys)
from Cons(2) show ?case
proof(cases xs rule: vfsequence_cases)
case 0 with Cons show ?thesis by (simp add: Cons.IH cr_vfsequence_def)
next
case (vcons xs' x)
interpret vfsequence xs' by (rule vcons(2))
note vcons_transfer = cr_vfsequence_vconsD[OF Cons(3)[unfolded vcons(1)]]
have a_ys: "list.set (a # ys) = insert a (list.set ys)" by simp
from vcons(2) have R_xs'x: "ℛ⇩∘ (xs' #⇩∘ x) = vinsert x (ℛ⇩∘ xs')" by simp
show "elts (ℛ⇩∘ xs) = (list.set (a # ys))"
unfolding vcons(1) R_xs'x a_ys
by
(
auto simp:
vcons_transfer(2) Cons(1)[OF vfsequence_axioms vcons_transfer(1)]
)
qed
qed (auto simp: cr_vfsequence_def)
qed
lemma vcard_transfer[transfer_rule]:
"(cr_vfsequence ===> cr_omega) vcard length"
proof(intro rel_funI)
fix xs ys assume prems: "cr_vfsequence xs ys"
then have "xs = vfsequence_of_vlist ys" unfolding cr_vfsequence_def by simp
then have "vfsequence xs" by (simp add: vfsequence_vfsequence_of_vlist)
from this prems show "cr_omega (vcard xs) (length ys)"
proof(induction ys arbitrary: xs)
case (Cons y ys)
from Cons(2) show ?case
proof(cases xs rule: vfsequence_cases)
case 0 with Cons show ?thesis by (simp add: Cons.IH cr_vfsequence_def)
next
case (vcons xs' x)
interpret vfsequence xs' by (rule vcons(2))
note vcons_transfer = cr_vfsequence_vconsD[OF Cons(3)[unfolded vcons(1)]]
have vcard_xs_x: "vcard (xs' #⇩∘ x) = succ (vcard xs')" by simp
have vcard_y_ys: "length (y # ys) = Suc (length ys)" by simp
from vfsequence_axioms have [transfer_rule]:
"cr_omega (vcard xs') (length ys)"
by (simp add: vcons_transfer(1) Cons.IH)
show ?thesis unfolding vcons(1) vcard_xs_x vcard_y_ys by transfer_prover
qed
qed (auto simp: cr_omega_def cr_vfsequence_def)
qed
lemma vcard_ll_transfer[transfer_rule]:
"(cr_cr_vfsequence ===> cr_omega) vcard length"
unfolding cr_cr_vfsequence_def
by (intro rel_funI)
(metis cr_vfsequence_def length_map rel_funD vcard_transfer)
end
text‹Corollaries.›
lemma vrange_vfsequence_of_vlist:
"ℛ⇩∘ (vfsequence_of_vlist xs) = set (list.set xs)"
proof(intro vsubset_antisym vsubsetI)
fix x assume prems: "x ∈⇩∘ ℛ⇩∘ (vfsequence_of_vlist xs)"
define ys where "ys = vfsequence_of_vlist xs"
have [transfer_rule]: "cr_vfsequence ys xs" "x = x"
unfolding ys_def cr_vfsequence_def by simp_all
show "x ∈⇩∘ set (list.set xs)" by transfer (simp add: prems[folded ys_def])
next
fix x assume prems: "x ∈⇩∘ set (list.set xs)"
define ys where "ys = vfsequence_of_vlist xs"
have [transfer_rule]: "cr_vfsequence ys xs" "x = x"
unfolding ys_def cr_vfsequence_def by simp_all
from prems[untransferred] show "x ∈⇩∘ ℛ⇩∘ (vfsequence_of_vlist xs)"
unfolding ys_def by simp
qed
lemma cr_cr_vfsequence_transfer_domain_rule[transfer_domain_rule]:
"Domainp cr_cr_vfsequence =
(λxss. vfsequence xss ∧ (∀xs∈⇩∘ℛ⇩∘ xss. vfsequence xs))"
proof(intro HOL.ext, rule iffI; (elim conjE | intro conjI ballI))
fix xss assume prems: "Domainp cr_cr_vfsequence xss"
with vfsequence_vfsequence_of_vlist show xss: "vfsequence xss"
unfolding cr_cr_vfsequence_def by clarsimp
interpret vfsequence xss by (rule xss)
fix xs assume prems': "xs ∈⇩∘ ℛ⇩∘ xss"
from prems obtain yss where xss_def:
"xss = vfsequence_of_vlist (map vfsequence_of_vlist yss)"
unfolding cr_cr_vfsequence_def by clarsimp
from prems' have "xs ∈⇩∘ set (list.set (map vfsequence_of_vlist yss))"
unfolding xss_def vrange_vfsequence_of_vlist by simp
then obtain ys where xs_def: "xs = vfsequence_of_vlist ys" by clarsimp
show "vfsequence xs"
unfolding xs_def by (simp add: vfsequence_vfsequence_of_vlist)
next
fix xss assume prems: "vfsequence xss" "∀xs∈⇩∘ℛ⇩∘ xss. vfsequence xs"
have "∃yss. xss = vfsequence_of_vlist (map vfsequence_of_vlist yss)"
using prems
proof(induction rule: vfsequence_induct)
case (vcons xss x)
let ?y = ‹vlist_of_vfsequence x›
from vcons(2,3) obtain yss where xss_def:
"xss = vfsequence_of_vlist (map vfsequence_of_vlist yss)"
by auto
from vcons(3) have "vfsequence x" by auto
then have x_def: "x = vfsequence_of_vlist (vlist_of_vfsequence x)" by simp
then have
"xss #⇩∘ x = vfsequence_of_vlist (map vfsequence_of_vlist (?y # yss))"
unfolding xss_def by simp
then show ?case by blast
qed (auto intro: exI[of _ ‹[]›])
then show "Domainp cr_cr_vfsequence xss"
unfolding cr_cr_vfsequence_def by blast
qed
subsubsection‹Appending elements›
definition vappend :: "V ⇒ V ⇒ V" (infixr "@⇩∘" 65)
where "xs @⇩∘ ys =
vfsequence_of_vlist (vlist_of_vfsequence ys @ vlist_of_vfsequence xs)"
text‹Transfer.›
lemma vappend_transfer[transfer_rule]:
includes lifting_syntax
shows "(cr_vfsequence ===> cr_vfsequence ===> cr_vfsequence)
(λxs ys. vappend ys xs) append"
by (intro rel_funI, unfold cr_vfsequence_def) (simp add: vappend_def)
lemma vappend_ll_transfer[transfer_rule]:
includes lifting_syntax
shows "(cr_cr_vfsequence ===> cr_cr_vfsequence ===> cr_cr_vfsequence)
(λxs ys. vappend ys xs) append"
by (intro rel_funI, unfold cr_cr_vfsequence_def) (simp add: vappend_def)
text‹Elementary properties.›
lemma (in vfsequence) vfsequence_vappend_vempty_vfsequence[simp]:
"[]⇩∘ @⇩∘ xs = xs"
unfolding vappend_def by auto
lemmas vfsequence_vappend_vempty_vfsequence[simp] =
vfsequence.vfsequence_vappend_vempty_vfsequence
lemma (in vfsequence) vfsequence_vappend_vfsequence_vempty[simp]:
"xs @⇩∘ []⇩∘ = xs"
unfolding vappend_def by auto
lemmas vfsequence_vappend_vfsequence_vempty[simp] =
vfsequence.vfsequence_vappend_vfsequence_vempty
lemma vappend_vcons[simp]:
assumes "vfsequence xs" and "vfsequence ys"
shows "xs @⇩∘ (ys #⇩∘ y) = (xs @⇩∘ ys) #⇩∘ y"
using append_Cons[where 'a=V, untransferred, OF assms(2,1)] by simp
subsubsection‹Distinct elements›
definition vdistinct :: "V ⇒ bool"
where "vdistinct xs = distinct (vlist_of_vfsequence xs)"
text‹Transfer.›
lemma vdistinct_transfer[transfer_rule]:
includes lifting_syntax
shows "(cr_vfsequence ===> (=)) vdistinct distinct"
by (intro rel_funI, unfold cr_vfsequence_def) (simp add: vdistinct_def)
lemma vdistinct_ll_transfer[transfer_rule]:
includes lifting_syntax
shows "(cr_cr_vfsequence ===> (=)) vdistinct distinct"
by (intro rel_funI, unfold cr_cr_vfsequence_def)
(
metis
vdistinct_def
distinct_map
inj_onI
vlist_of_vfsequence_vfsequence_of_vlist
)
text‹Elementary properties.›
lemma (in vfsequence) vfsequence_vdistinct_if_vcard_vrange_eq_vcard:
assumes "vcard (ℛ⇩∘ xs) = vcard xs"
shows "vdistinct xs"
proof-
have "finite (elts (ℛ⇩∘ xs))" by (simp add: assms vcard_vfinite_omega)
from vcard_finite_set[OF this] assms have "card (elts (ℛ⇩∘ xs))⇩ℕ = vcard xs"
by simp
from card_distinct[where ?'a=V, untransferred, OF vfsequence_axioms this]
show ?thesis.
qed
lemma vdistinct_vempty[intro, simp]: "vdistinct []⇩∘"
proof-
have t: "distinct ([]::V list)" by simp
show ?thesis by (rule t[untransferred])
qed
lemma (in vfsequence) vfsequence_vcons_vdistinct:
assumes "vdistinct (xs #⇩∘ x)"
shows "vdistinct xs"
proof-
from distinct.simps(2)[where 'a=V, THEN iffD1, THEN conjunct2, untransferred]
show ?thesis
using vfsequence_axioms assms by simp
qed
lemma (in vfsequence) vfsequence_vcons_nin_vrange:
assumes "vdistinct (xs #⇩∘ x)"
shows "x ∉⇩∘ ℛ⇩∘ xs"
proof-
from distinct.simps(2)[where 'a=V, THEN iffD1, THEN conjunct1, untransferred]
show ?thesis
using vfsequence_axioms assms by simp
qed
lemma (in vfsequence) vfsequence_v11I[intro]:
assumes "vdistinct xs"
shows "v11 xs"
using vfsequence_axioms assms
proof(induction xs rule: vfsequence_induct)
case (vcons xs x)
interpret vfsequence xs by (rule vcons(1))
from vcons(3) have dxs: "vdistinct xs" by (rule vfsequence_vcons_vdistinct)
interpret v11 xs using dxs by (rule vcons(2))
from vfsequence_vcons_nin_vrange[OF vcons(3)] have "x ∉⇩∘ ℛ⇩∘ xs" .
show "v11 (xs #⇩∘ x)"
by
(
simp_all add:
vcons_def vfsequence_vdomain vfsequence_vcons_nin_vrange[OF vcons(3)]
)
qed simp
lemma (in vfsequence) vfsequence_vcons_vdistinctI:
assumes "vdistinct xs" and "x ∉⇩∘ ℛ⇩∘ xs"
shows "vdistinct (xs #⇩∘ x)"
proof-
have t: "distinct xs ⟹ x ∉ list.set xs ⟹ distinct (x # xs)"
for x ::V and xs
by simp
from vfsequence_axioms assms show ?thesis by (rule t[untransferred])
qed
lemmas vfsequence_vcons_vdistinctI[intro] =
vfsequence.vfsequence_vcons_vdistinctI
lemma (in vfsequence) vfsequence_nin_vrange_vcons:
assumes "y ∉⇩∘ ℛ⇩∘ xs" and "y ≠ x"
shows "y ∉⇩∘ ℛ⇩∘ (xs #⇩∘ x)"
proof-
have t: "y ∉ list.set xs ⟹ y ≠ x ⟹ y ∉ list.set (x # xs)"
for x y :: V and xs
by simp
from vfsequence_axioms assms show ?thesis by (rule t[untransferred])
qed
lemmas vfsequence_nin_vrange_vcons[intro] =
vfsequence.vfsequence_nin_vrange_vcons
subsubsection‹Concatenation of sequences›
definition vconcat :: "V ⇒ V"
where "vconcat xss =
vfsequence_of_vlist(
concat (map vlist_of_vfsequence (vlist_of_vfsequence xss))
)"
text‹Transfer.›
lemma vconcat_transfer[transfer_rule]:
includes lifting_syntax
shows "(cr_cr_vfsequence ===> cr_vfsequence) vconcat concat"
proof(intro rel_funI)
fix xs ys assume "cr_cr_vfsequence xs ys"
then have xs_def: "xs = vfsequence_of_vlist (map vfsequence_of_vlist ys)"
unfolding cr_cr_vfsequence_def by simp
have main_eq: "map vlist_of_vfsequence (vlist_of_vfsequence xs) = ys"
unfolding xs_def by (simp add: map_idI)
show "cr_vfsequence (vconcat xs) (concat ys)"
unfolding cr_vfsequence_def vconcat_def main_eq ..
qed
text‹Elementary properties.›
lemma vconcat_vempty[simp]: "vconcat []⇩∘ = []⇩∘"
unfolding vconcat_def by simp
lemma vconcat_append[simp]:
assumes "vfsequence xss"
and "∀xs∈⇩∘ℛ⇩∘ xss. vfsequence xs"
and "vfsequence yss"
and "∀xs∈⇩∘ℛ⇩∘ yss. vfsequence xs"
shows "vconcat (xss @⇩∘ yss) = vconcat xss @⇩∘ vconcat yss"
using assms concat_append[where 'a=V, untransferred] by simp
lemma vconcat_vcons[simp]:
assumes "vfsequence xs" and "vfsequence xss" and "∀xs∈⇩∘ℛ⇩∘ xss. vfsequence xs"
shows "vconcat (xss #⇩∘ xs) = vconcat xss @⇩∘ xs"
using assms concat.simps(2)[where 'a=V, untransferred] by simp
lemma (in vfsequence) vfsequence_vconcat_fsingleton[simp]: "vconcat [xs]⇩∘ = xs"
using vfsequence_axioms
by
(
metis
vfsequence_vappend_vempty_vfsequence
vconcat_vcons
vconcat_vempty
vempty_nin
vfsequence_vempty
vrange_vempty
)
lemmas vfsequence_vconcat_fsingleton[simp] =
vfsequence.vfsequence_vconcat_fsingleton
subsection‹Finite sequences and the Cartesian product›
lemma vfsequence_vcons_vproductI[intro!]:
assumes "n ∈⇩∘ ω"
and "xs ∈⇩∘ (∏⇩∘i∈⇩∘vcard xs. A i)"
and "x ∈⇩∘ A (vcard xs)"
and "n = vcard (xs #⇩∘ x)"
shows "xs #⇩∘ x ∈⇩∘ (∏⇩∘i∈⇩∘n. A i)"
proof
interpret xs: vfsequence xs
using assms
apply(intro vfsequenceI)
subgoal by auto
subgoal
by
(
metis
vcard_vfinite_omega
vcons_vsubset
vfinite_vcard_omega
vfinite_vsubset vproductD(2)
)
done
interpret xsx: vfsequence ‹xs #⇩∘ x› by auto
show "vsv (xs #⇩∘ x)" by (simp add: xsx.vsv_axioms)
show D: "𝒟⇩∘ (xs #⇩∘ x) = n" unfolding assms(4) xsx.vfsequence_vdomain by auto
from vproductD[OF assms(2)] have elem: "i ∈⇩∘ vcard xs ⟹ xs⦇i⦈ ∈⇩∘ A i" for i
by auto
show "∀i∈⇩∘n. (xs #⇩∘ x)⦇i⦈ ∈⇩∘ A i" by (auto simp: elem assms(3,4))
qed
lemma vfsequence_vcons_vproductD[dest]:
assumes "xs #⇩∘ x ∈⇩∘ (∏⇩∘i∈⇩∘n. A i)" and "n ∈⇩∘ ω"
shows "xs ∈⇩∘ (∏⇩∘i∈⇩∘vcard xs. A i)"
and "x ∈⇩∘ A (vcard xs)"
and "n = vcard (xs #⇩∘ x)"
proof-
interpret xsx: vfsequence ‹xs #⇩∘ x›
by (meson assms succ_in_omega vfsequence_vproduct)
interpret xs: vfsequence xs
by (blast intro: xsx.vfsequence_vremove_vcons_vfsequence)
show n_def: "n = vcard (xs #⇩∘ x)"
using assms using xsx.vfsequence_vdomain by blast
from vproductD[OF assms(1), unfolded n_def]
have elem_xs_x: "i ∈⇩∘ vcard (xs #⇩∘ x) ⟹ (xs #⇩∘ x)⦇i⦈ ∈⇩∘ A i"
for i
by auto
then have elem_xs[simp]: "i ∈⇩∘ vcard xs ⟹ xs⦇i⦈ ∈⇩∘ A i" for i
by (metis rev_vsubsetD vcard_mono vcons_vsubset xs.vfsequence_at_not_last)
show "xs ∈⇩∘ (∏⇩∘i∈⇩∘vcard xs. A i)"
by (auto simp: xs.vsv_axioms xs.vfsequence_vdomain)
from elem_xs_x show "x ∈⇩∘ A (vcard xs)" by fastforce
qed
lemma vfsequence_vcons_vproductE[elim!]:
assumes "xs #⇩∘ x ∈⇩∘ (∏⇩∘i∈⇩∘n. A i)" and "n ∈⇩∘ ω"
obtains "xs ∈⇩∘ (∏⇩∘i∈⇩∘vcard xs. A i)"
and "x ∈⇩∘ A (vcard xs)"
and "n = vcard (xs #⇩∘ x)"
using assms by (auto simp: vfsequence_vcons_vproductD)
subsection‹Binary Cartesian product based on finite sequences: ‹ftimes››
definition ftimes :: "V ⇒ V ⇒ V" (infixr ‹×⇩∙› 80)
where "ftimes a b ≡ (∏⇩∘i∈⇩∘2⇩ℕ. if i = 0 then a else b)"
lemma small_fpairs[simp]: "small {[a, b]⇩∘ | a b. [a, b]⇩∘ ∈⇩∘ r}"
by (rule down[of _ r]) clarsimp
text‹Rules.›
lemma ftimesI1[intro]:
assumes "x = [a, b]⇩∘" and "a ∈⇩∘ A" and "b ∈⇩∘ B"
shows "x ∈⇩∘ A ×⇩∙ B"
unfolding ftimes_def
proof
show vsv: "vsv x" by (simp add: assms(1) vfsequence.axioms(1))
then interpret vsv x .
from assms show D: "𝒟⇩∘ x = 2⇩ℕ"
unfolding nat_omega_simps two One_nat_def by auto
from assms(2,3) have i: "i ∈⇩∘ 2⇩ℕ ⟹ x⦇i⦈ ∈⇩∘ (if i = 0⇩ℕ then A else B)"
for i
unfolding assms(1) two nat_omega_simps One_nat_def by auto
from i show "∀i∈⇩∘2⇩ℕ. x⦇i⦈ ∈⇩∘ (if i = 0 then A else B)" by auto
qed
lemma ftimesI2[intro!]:
assumes "a ∈⇩∘ A" and "b ∈⇩∘ B"
shows "[a, b]⇩∘ ∈⇩∘ A ×⇩∙ B"
using assms ftimesI1 by auto
lemma fproductE1[elim!]:
assumes "x ∈⇩∘ A ×⇩∙ B"
obtains a b where "x = [a, b]⇩∘" and "a ∈⇩∘ A" and "b ∈⇩∘ B"
proof-
from vproduct_vdoubletonD[OF assms[unfolded two ftimes_def]]
have x_def: "x = set {⟨0⇩ℕ, x⦇0⇩ℕ⦈⟩, ⟨1⇩ℕ, x⦇1⇩ℕ⦈⟩}"
and "x⦇0⇩ℕ⦈ ∈⇩∘ A"
and "x⦇1⇩ℕ⦈ ∈⇩∘ B"
by auto
then show ?thesis using that using vcons_vdoubleton by simp
qed
lemma fproductE2[elim!]:
assumes "[a, b]⇩∘ ∈⇩∘ A ×⇩∙ B" obtains "a ∈⇩∘ A" and "b ∈⇩∘ B"
using assms by blast
text‹Set operations.›
lemma vfinite_0_left[simp]: "0 ×⇩∙ b = 0"
by (meson eq0_iff fproductE1)
lemma vfinite_0_right[simp]: "a ×⇩∙ 0 = 0"
by (meson eq0_iff fproductE1)
lemma fproduct_vintersection: "(a ∩⇩∘ b) ×⇩∙ (c ∩⇩∘ d) = (a ×⇩∙ c) ∩⇩∘ (b ×⇩∙ d)"
by auto
lemma fproduct_vdiff: "a ×⇩∙ (b -⇩∘ c) = (a ×⇩∙ b) -⇩∘ (a ×⇩∙ c)" by auto
lemma vfinite_ftimesI[intro!]:
assumes "vfinite a" and "vfinite b"
shows "vfinite (a ×⇩∙ b)"
using assms(1,2)
proof(induction arbitrary: b rule: vfinite_induct)
case (vinsert x a')
from vinsert(4) have "vfinite (set {x} ×⇩∙ b)"
proof(induction rule: vfinite_induct)
case (vinsert y b')
have "set {x} ×⇩∙ vinsert y b' = vinsert [x, y]⇩∘ (set {x} ×⇩∙ b')" by auto
with vinsert(3) show ?case by simp
qed simp
moreover have "vinsert x a' ×⇩∙ b = (set {x} ×⇩∙ b) ∪⇩∘ (a' ×⇩∙ b)" by auto
ultimately show ?case using vinsert by (auto simp: vfinite_vunionI)
qed simp
text‹‹ftimes› and ‹vcpower››
lemma vproduct_vpair: "[a, b]⇩∘ ∈⇩∘ (∏⇩∘i∈⇩∘2⇩ℕ. f i) ⟷ ⟨a, b⟩ ∈⇩∘ f (0⇩ℕ) ×⇩∘ f (1⇩ℕ)"
proof
interpret vfsequence ‹[a, b]⇩∘› by simp
show "[a, b]⇩∘ ∈⇩∘ (∏⇩∘i∈⇩∘2⇩ℕ. f i) ⟹ ⟨a, b⟩ ∈⇩∘ f (0⇩ℕ) ×⇩∘ f (1⇩ℕ)"
unfolding vcons_vdoubleton two by (elim vproduct_vdoubletonE) auto
assume hyp: "⟨a, b⟩ ∈⇩∘ f (0⇩ℕ) ×⇩∘ f (1⇩ℕ)"
then have af: "a ∈⇩∘ f (0⇩ℕ)" and bf: "b ∈⇩∘ f (1⇩ℕ)" by auto
have dom: "𝒟⇩∘ [a, b]⇩∘ = set {0⇩ℕ, 1⇩ℕ}" by (auto intro!: vsubset_antisym)
have ran: "ℛ⇩∘ [a, b]⇩∘ ⊆⇩∘ (⋃⇩∘i∈⇩∘2⇩ℕ. f i)"
unfolding two using af bf vifunion_vdoubleton by auto
show "[a, b]⇩∘ ∈⇩∘ (∏⇩∘i∈⇩∘2⇩ℕ. f i)"
apply(intro vproductI)
subgoal using dom ran vsv_axioms unfolding two by auto
subgoal using af bf unfolding two by (auto intro!: vsubset_antisym)
subgoal
unfolding two
using hyp VSigmaE2 small_empty vcons_vdoubleton
by (auto simp: vinsert_set_insert_eq)
done
qed
text‹Connections.›
lemma vcpower_two_ftimes: "A ^⇩× 2⇩ℕ = A ×⇩∙ A"
unfolding vcpower_def ftimes_def two by simp
lemma vcpower_two_ftimesI[intro]:
assumes "x ∈⇩∘ A ×⇩∙ A"
shows "x ∈⇩∘ A ^⇩× 2⇩ℕ"
using assms unfolding ftimes_def two by auto
lemma vcpower_two_ftimesD[dest]:
assumes "x ∈⇩∘ A ^⇩× 2⇩ℕ"
shows "x ∈⇩∘ A ×⇩∙ A"
using assms unfolding vcpower_def ftimes_def two by simp
lemma vcpower_two_ftimesE[elim]:
assumes "x ∈⇩∘ A ^⇩× 2⇩ℕ" and "x ∈⇩∘ A ×⇩∙ A ⟹ P"
shows P
using assms unfolding vcpower_def ftimes_def two by simp
lemma vfsequence_vcpower_two_vpair: "[a, b]⇩∘ ∈⇩∘ A ^⇩× 2⇩ℕ ⟷ ⟨a, b⟩ ∈⇩∘ A ×⇩∘ A"
proof(rule iffI)
show "[a, b]⇩∘ ∈⇩∘ A ^⇩× 2⇩ℕ ⟹ ⟨a, b⟩ ∈⇩∘ A ×⇩∘ A"
by (elim vcpowerE, unfold vproduct_vpair)
qed (intro vcpowerI, unfold vproduct_vpair)
lemma vsv_vfsequence_two:
assumes "vsv gf" and "𝒟⇩∘ gf = 2⇩ℕ"
shows "[vpfst gf, vpsnd gf]⇩∘ = gf"
proof-
interpret gf: vsv gf by (auto intro: assms(1))
show ?thesis
by
(
rule sym,
rule vsv_eqI,
blast,
blast,
simp add: assms(2) nat_omega_simps,
unfold assms(2),
elim_in_numeral,
all‹simp add: nat_omega_simps›
)
qed
lemma vsv_vfsequence_three:
assumes "vsv hgf" and "𝒟⇩∘ hgf = 3⇩ℕ"
shows "[vpfst hgf, vpsnd hgf, vpthrd hgf]⇩∘ = hgf"
proof-
interpret hgf: vsv hgf by (auto intro: assms(1))
show ?thesis
by
(
rule sym,
rule vsv_eqI,
blast,
blast,
simp add: assms(2) nat_omega_simps,
unfold assms(2),
elim_in_numeral,
all‹simp add: nat_omega_simps›
)
qed
subsection‹Sequence as an element of a Cartesian power of a set›
lemma vcons_in_vcpowerI[intro!]:
assumes "n ∈⇩∘ ω"
and "xs ∈⇩∘ A ^⇩× vcard xs"
and "x ∈⇩∘ A"
and "n = vcard (xs #⇩∘ x)"
shows "xs #⇩∘ x ∈⇩∘ A ^⇩× n"
proof-
interpret vfsequence xs
using assms
by
(
meson
vcons_vsubset
vfinite_vcard_omega_iff
vfinite_vsubset
vfsequence_vcpower
)
show ?thesis
by
(
metis
assms(2,3,4)
vcpower_vrange
vfsequence_vcons
vfsequence_vcons_vrange
vfsequence.vfsequence_vrange_vcpower
vsubset_vinsert_leftI
)
qed
lemma vcons_in_vcpowerD[dest]:
assumes "xs #⇩∘ x ∈⇩∘ A ^⇩× n" and "n ∈⇩∘ ω"
shows "xs ∈⇩∘ A ^⇩× vcard xs"
and "x ∈⇩∘ A"
and "n = vcard (xs #⇩∘ x)"
proof-
interpret vfsequence xs
by
(
meson
assms
vfsequence.vfsequence_vremove_vcons_vfsequence
vfsequence_vcpower
)
from assms vfsequence_vcard_vcons show "n = vcard (xs #⇩∘ x)" by auto
then show "xs ∈⇩∘ A ^⇩× vcard xs"
by
(
metis
assms(1)
vcpower_vrange
vfsequence_vcons_vrange
vfsequence_vrange_vcpower
vsubset_vinsert_leftD
)
show "x ∈⇩∘ A"
by
(
metis
assms(1)
vcpower_vrange
vfsequence.vfsequence_vcons_vrange
vfsequence_axioms
vinsertI1
vsubsetE
)
qed
lemma vcons_in_vcpowerE1[elim!]:
assumes "xs #⇩∘ x ∈⇩∘ A ^⇩× n" and "n ∈⇩∘ ω"
obtains "xs ∈⇩∘ A ^⇩× vcard xs" and "x ∈⇩∘ A" and "n = vcard (xs #⇩∘ x)"
using assms by blast
lemma vcons_in_vcpowerE2:
assumes "xs ∈⇩∘ A ^⇩× n" and "n ∈⇩∘ ω" and "0 ∈⇩∘ n"
obtains x xs' where "xs = xs' #⇩∘ x"
and "xs' ∈⇩∘ A ^⇩× vcard xs'"
and "x ∈⇩∘ A"
and "n = vcard (xs' #⇩∘ x)"
proof-
interpret vfsequence xs using assms(1,2) by auto
from assms obtain x xs' where xs_def: "xs = xs' #⇩∘ x"
by
(
metis
eq0_iff vcard_0 vcpower_vdomain vfsequence_vcons_ex vfsequence_vdomain
)
from vcons_in_vcpowerE1[OF assms(1)[unfolded xs_def] assms(2)] have
"xs' ∈⇩∘ A ^⇩× vcard xs'" and "x ∈⇩∘ A" and "n = vcard (xs' #⇩∘ x)"
by blast+
from xs_def this show ?thesis by (clarsimp simp: that)
qed
lemma vcons_vcpower1E:
assumes "xs ∈⇩∘ A ^⇩× 1⇩ℕ"
obtains x where "xs = [x]⇩∘" and "x ∈⇩∘ A"
proof-
have 01: "0 ∈⇩∘ 1⇩ℕ" by simp
from vcons_in_vcpowerE2[OF assms ord_of_nat_ω 01] obtain x xs'
where xs_def: "xs = xs' #⇩∘ x"
and xs': "xs' ∈⇩∘ A ^⇩× vcard xs'"
and x: "x ∈⇩∘ A"
and one: "1⇩ℕ = vcard (xs' #⇩∘ x)"
by metis
interpret xs: vfsequence xs using assms by (auto intro: vfsequence_vcpower)
interpret xs': vfsequence xs'
using xs' xs_def xs.vfsequence_vremove_vcons_vfsequence by blast
from one have "vcard xs' = 0"
by (metis ord_of_nat_succ_vempty succ_inject_iff xs'.vfsequence_vcard_vcons)
then have "xs = [x]⇩∘" unfolding xs_def by (simp add: vcard_vempty)
with x that show ?thesis by simp
qed
text‹\newpage›
end
Theory CZH_Sets_FBRelations
section‹Binary relation as a finite sequence›
theory CZH_Sets_FBRelations
imports CZH_Sets_FSequences
begin
subsection‹Background›
text‹
This section exposes the theory of binary relations that are represented by
a two element finite sequence ‹[a, b]⇩∘› (as opposed to a pair ‹⟨a, b⟩›).
Many results were adapted from the theory ‹CZH_Sets_BRelations›.
As previously, many of the results that are presented in this
section can be assumed to have been adapted (with amendments) from the
theory \<^text>‹Relation› in the main library.
›
lemma fpair_iff[simp]: "([a, b]⇩∘ = [a', b']⇩∘) = (a = a' ∧ b = b')" by simp
lemmas fpair_inject[elim!] = fpair_iff[THEN iffD1, THEN conjE]
subsection‹‹fpairs››
definition fpairs :: "V ⇒ V" where
"fpairs r = set {x. x ∈⇩∘ r ∧ (∃a b. x = [a, b]⇩∘)}"
lemma small_fpairs[simp]: "small {x. x ∈⇩∘ r ∧ (∃a b. x = [a, b]⇩∘)}"
by (rule down[of _ r]) clarsimp
text‹Rules.›
lemma fpairsI[intro]:
assumes "x ∈⇩∘ r" and "x = [a, b]⇩∘"
shows "x ∈⇩∘ fpairs r"
using assms unfolding fpairs_def by auto
lemma fpairsD[dest]:
assumes "x ∈⇩∘ fpairs r"
shows "x ∈⇩∘ r" and "∃a b. x = [a, b]⇩∘"
using assms unfolding fpairs_def by auto
lemma fpairsE[elim]:
assumes "x ∈⇩∘ fpairs r"
obtains a b where "x = [a, b]⇩∘" and "[a, b]⇩∘ ∈⇩∘ r"
using assms unfolding fpairs_def by auto
lemma fpairs_iff: "x ∈⇩∘ fpairs r ⟷ x ∈⇩∘ r ∧ (∃a b. x = [a, b]⇩∘)" by auto
text‹Elementary properties.›
lemma fpairs_iff_elts: "[a, b]⇩∘ ∈⇩∘ fpairs r ⟷ [a, b]⇩∘ ∈⇩∘ r" by auto
text‹Set operations.›
lemma fpairs_vempty[simp]: "fpairs 0 = 0" by auto
lemma fpairs_vsingleton[simp]: "fpairs (set {[a, b]⇩∘}) = set {[a, b]⇩∘}" by auto
lemma fpairs_vinsert: "fpairs (vinsert [a, b]⇩∘ A) = set {[a, b]⇩∘} ∪⇩∘ fpairs A"
by auto
lemma fpairs_mono:
assumes "r ⊆⇩∘ s"
shows "fpairs r ⊆⇩∘ fpairs s"
using assms by blast
lemma fpairs_vunion: "fpairs (A ∪⇩∘ B) = fpairs A ∪⇩∘ fpairs B" by auto
lemma fpairs_vintersection: "fpairs (A ∩⇩∘ B) = fpairs A ∩⇩∘ fpairs B" by auto
lemma fpairs_vdiff: "fpairs (A -⇩∘ B) = fpairs A -⇩∘ fpairs B" by auto
text‹Special properties.›
lemma fpairs_ex_vfst:
assumes "x ∈⇩∘ fpairs r"
shows "∃b. [x⦇0⇩ℕ⦈, b]⇩∘ ∈⇩∘ r"
proof-
from assms have xr: "x ∈⇩∘ r" by auto
moreover from assms obtain b where x_def: "x = [x⦇0⇩ℕ⦈, b]⇩∘" by auto
ultimately have "[x⦇0⇩ℕ⦈, b]⇩∘ ∈⇩∘ r" by auto
then show ?thesis by auto
qed
lemma fpairs_ex_vsnd:
assumes "x ∈⇩∘ fpairs r"
shows "∃a. [a, x⦇1⇩ℕ⦈]⇩∘ ∈⇩∘ r"
proof-
from assms have xr: "x ∈⇩∘ r" by auto
moreover from assms obtain a where x_def: "x = [a, x⦇1⇩ℕ⦈]⇩∘"
by (auto simp: nat_omega_simps)
ultimately have "[a, x⦇1⇩ℕ⦈]⇩∘ ∈⇩∘ r" by auto
then show ?thesis by auto
qed
lemma fpair_vcpower2I[intro]:
assumes "a ∈⇩∘ A ^⇩× 1⇩ℕ" and "b ∈⇩∘ A ^⇩× 1⇩ℕ"
shows "vconcat [a, b]⇩∘ ∈⇩∘ A ^⇩× 2⇩ℕ"
proof-
from assms obtain a' b'
where a_def: "a = [a']⇩∘" and b_def: "b = [b']⇩∘" and "a'∈⇩∘ A" and "b'∈⇩∘ A"
by (force elim: vcons_vcpower1E)
then show ?thesis by (auto simp: nat_omega_simps)
qed
subsection‹Constructors›
subsubsection‹Identity relation›
definition fid_on :: "V ⇒ V"
where "fid_on A = set {[a, a]⇩∘ | a. a ∈⇩∘ A}"
lemma fid_on_small[simp]: "small {[a, a]⇩∘ | a. a ∈⇩∘ A}"
proof(rule down[of _ ‹A ^⇩× (2⇩ℕ)›], intro subsetI)
fix x assume "x ∈ {[a, a]⇩∘ |a. a ∈⇩∘ A}"
then obtain a where x_def: "x = [a, a]⇩∘" and "a ∈⇩∘ A" by clarsimp
interpret vfsequence ‹[a, a]⇩∘› by simp
have vcard_aa: "2⇩ℕ = vcard [a, a]⇩∘" by (simp add: nat_omega_simps)
from ‹a ∈⇩∘ A› show "x ∈⇩∘ A ^⇩× 2⇩ℕ"
unfolding x_def vcard_aa by (intro vfsequence_vrange_vcpower) auto
qed
text‹Rules.›
lemma fid_on_eqI:
assumes "a = b" and "a ∈⇩∘ A"
shows "[a, b]⇩∘ ∈⇩∘ fid_on A"
using assms by (simp add: fid_on_def)
lemma fid_onI[intro!]:
assumes "a ∈⇩∘ A"
shows "[a, a]⇩∘ ∈⇩∘ fid_on A"
by (rule fid_on_eqI) (simp_all add: assms)
lemma fid_onD[dest!]:
assumes "[a, a]⇩∘ ∈⇩∘ fid_on A"
shows "a ∈⇩∘ A"
using assms unfolding fid_on_def by auto
lemma fid_onE[elim!]:
assumes "x ∈⇩∘ fid_on A" and "∃a∈⇩∘A. x = [a, a]⇩∘ ⟹ P"
shows P
using assms unfolding fid_on_def by auto
lemma fid_on_iff: "[a, b]⇩∘ ∈⇩∘ fid_on A ⟷ a = b ∧ a ∈⇩∘ A" by auto
text‹Set operations.›
lemma fid_on_vempty[simp]: "fid_on 0 = 0" by auto
lemma fid_on_vsingleton[simp]: "fid_on (set {a}) = set {[a, a]⇩∘}" by auto
lemma fid_on_vdoubleton: "fid_on (set {a, b}) = set {[a, a]⇩∘, [b, b]⇩∘}" by force
lemma fid_on_mono:
assumes "A ⊆⇩∘ B"
shows "fid_on A ⊆⇩∘ fid_on B"
using assms by auto
lemma fid_on_vinsert: "vinsert [a, a]⇩∘ (fid_on A) = fid_on (vinsert a A)"
by auto
lemma fid_on_vintersection: "fid_on (A ∩⇩∘ B) = fid_on A ∩⇩∘ fid_on B" by auto
lemma fid_on_vunion: "fid_on (A ∪⇩∘ B) = fid_on A ∪⇩∘ fid_on B" by auto
lemma fid_on_vdiff: "fid_on (A -⇩∘ B) = fid_on A -⇩∘ fid_on B" by auto
text‹Special properties.›
lemma fid_on_vsubset_vcpower: "fid_on A ⊆⇩∘ A ^⇩× 2⇩ℕ" by force
subsubsection‹Constant function›
definition fconst_on :: "V ⇒ V ⇒ V"
where "fconst_on A c = set {[a, c]⇩∘ | a. a ∈⇩∘ A}"
lemma small_fconst_on[simp]: "small {[a, c]⇩∘ | a. a ∈⇩∘ A}"
by (rule down[of _ ‹A ×⇩∙ set {c}›]) blast
text‹Rules.›
lemma fconst_onI[intro!]:
assumes "a ∈⇩∘ A"
shows "[a, c]⇩∘ ∈⇩∘ fconst_on A c"
using assms unfolding fconst_on_def by simp
lemma fconst_onD[dest!]:
assumes "[a, c]⇩∘ ∈⇩∘ fconst_on A c"
shows "a ∈⇩∘ A"
using assms unfolding fconst_on_def by simp
lemma fconst_onE[elim!]:
assumes "x ∈⇩∘ fconst_on A c"
obtains a where "a ∈⇩∘ A" and "x = [a, c]⇩∘"
using assms unfolding fconst_on_def by auto
lemma fconst_on_iff: "[a, c]⇩∘ ∈⇩∘ fconst_on A c ⟷ a ∈⇩∘ A" by auto
text‹Set operations.›
lemma fconst_on_vempty[simp]: "fconst_on 0 c = 0"
unfolding fconst_on_def by auto
lemma fconst_on_vsingleton[simp]: "fconst_on (set {a}) c = set {[a, c]⇩∘}"
by auto
lemma fconst_on_vdoubleton: "fconst_on (set {a, b}) c = set {[a, c]⇩∘, [b, c]⇩∘}"
by force
lemma fconst_on_mono:
assumes "A ⊆⇩∘ B"
shows "fconst_on A c ⊆⇩∘ fconst_on B c"
using assms by auto
lemma fconst_on_vinsert:
"(vinsert [a, c]⇩∘ (fconst_on A c)) = (fconst_on (vinsert a A) c)"
by auto
lemma fconst_on_vintersection:
"fconst_on (A ∩⇩∘ B) c = fconst_on A c ∩⇩∘ fconst_on B c"
by auto
lemma fconst_on_vunion: "fconst_on (A ∪⇩∘ B) c = fconst_on A c ∪⇩∘ fconst_on B c"
by auto
lemma fconst_on_vdiff: "fconst_on (A -⇩∘ B) c = fconst_on A c -⇩∘ fconst_on B c"
by auto
text‹Special properties.›
lemma fconst_on_eq_ftimes: "fconst_on A c = A ×⇩∙ set {c}" by blast
subsubsection‹Composition›
definition fcomp :: "V ⇒ V ⇒ V" (infixr ‹∘⇩∙› 75)
where "r ∘⇩∙ s = set {[a, c]⇩∘ | a c. ∃b. [a, b]⇩∘ ∈⇩∘ s ∧ [b, c]⇩∘ ∈⇩∘ r}"
notation fcomp (infixr "∘⇩∙" 75)
lemma fcomp_small[simp]: "small {[a, c]⇩∘ | a c. ∃b. [a, b]⇩∘ ∈⇩∘ s ∧ [b, c]⇩∘ ∈⇩∘ r}"
(is ‹small ?s›)
proof-
define comp' where "comp' = (λ⟨ab, cd⟩. [ab⦇0⇩ℕ⦈, cd⦇1⇩ℕ⦈]⇩∘)"
have "small (elts (vpairs (s ×⇩∘ r)))" by simp
then have small_comp: "small (comp' ` elts (vpairs (s ×⇩∘ r)))" by simp
have ss: "?s ⊆ (comp' ` elts (vpairs (s ×⇩∘ r)))"
proof
fix x assume "x ∈ ?s"
then obtain a b c where x_def: "x = [a, c]⇩∘"
and "[a, b]⇩∘ ∈⇩∘ s"
and "[b, c]⇩∘ ∈⇩∘ r"
by auto
then have abbc: "⟨[a, b]⇩∘, [b, c]⇩∘⟩ ∈⇩∘ vpairs (s ×⇩∘ r)"
by (simp add: vpairs_iff_elts)
have x_def': "x = comp' ⟨[a, b]⇩∘, [b, c]⇩∘⟩"
unfolding comp'_def x_def by (auto simp: nat_omega_simps)
then show "x ∈ comp' ` elts (vpairs (s ×⇩∘ r))"
unfolding x_def' using abbc by auto
qed
with small_comp show ?thesis by (meson smaller_than_small)
qed
text‹Rules.›
lemma fcompI[intro]:
assumes "[b, c]⇩∘ ∈⇩∘ r" and "[a, b]⇩∘ ∈⇩∘ s"
shows "[a, c]⇩∘ ∈⇩∘ r ∘⇩∙ s"
using assms unfolding fcomp_def by auto
lemma fcompD[dest]:
assumes "[a, c]⇩∘ ∈⇩∘ r ∘⇩∙ s"
shows "∃b. [b, c]⇩∘ ∈⇩∘ r ∧ [a, b]⇩∘ ∈⇩∘ s"
using assms unfolding fcomp_def by auto
lemma fcompE[elim]:
assumes "ac ∈⇩∘ r ∘⇩∙ s"
obtains a b c where "ac = [a, c]⇩∘" and "[a, b]⇩∘ ∈⇩∘ s" and "[b, c]⇩∘ ∈⇩∘ r"
using assms unfolding fcomp_def by clarsimp
text‹Elementary properties.›
lemma fcomp_assoc: "(r ∘⇩∙ s) ∘⇩∙ t = r ∘⇩∙ (s ∘⇩∙ t)" by fast
text‹Set operations.›
lemma fcomp_vempty_left[simp]: "0 ∘⇩∙ r = 0" unfolding vcomp_def by force
lemma fcomp_vempty_right[simp]: "r ∘⇩∙ 0 = 0" unfolding vcomp_def by force
lemma fcomp_mono:
assumes "r' ⊆⇩∘ r" and "s' ⊆⇩∘ s"
shows "r' ∘⇩∙ s' ⊆⇩∘ r ∘⇩∙ s"
using assms by force
lemma fcomp_vinsert_left[simp]:
"vinsert ([a, b]⇩∘) s ∘⇩∙ r = (set {[a, b]⇩∘} ∘⇩∙ r) ∪⇩∘ (s ∘⇩∙ r)"
by auto
lemma fcomp_vinsert_right[simp]:
"r ∘⇩∙ vinsert [a, b]⇩∘ s = (r ∘⇩∙ set {[a, b]⇩∘}) ∪⇩∘ (r ∘⇩∙ s)"
by auto
lemma fcomp_vunion_left[simp]: "(s ∪⇩∘ t) ∘⇩∙ r = (s ∘⇩∙ r) ∪⇩∘ (t ∘⇩∙ r)" by auto
lemma fcomp_vunion_right[simp]: "r ∘⇩∙ (s ∪⇩∘ t) = (r ∘⇩∙ s) ∪⇩∘ (r ∘⇩∙ t)" by auto
text‹Connections.›
lemma fcomp_fid_on_idem[simp]: "fid_on A ∘⇩∙ fid_on A = fid_on A" by auto
lemma fcomp_fid_on[simp]: "fid_on A ∘⇩∙ fid_on B = fid_on (A ∩⇩∘ B)" by auto
lemma fcomp_fconst_on_fid_on[simp]: "fconst_on A c ∘⇩∙ fid_on A = fconst_on A c"
by auto
text‹Special properties.›
lemma fcomp_vsubset_vtimes:
assumes "r ⊆⇩∘ B ×⇩∙ C" and "s ⊆⇩∘ A ×⇩∙ B"
shows "r ∘⇩∙ s ⊆⇩∘ A ×⇩∙ C"
using assms by blast
lemma fcomp_obtain_middle[elim]:
assumes "[a, c]⇩∘ ∈⇩∘ f ∘⇩∙ g"
obtains b where "[a, b]⇩∘ ∈⇩∘ g" and "[b, c]⇩∘ ∈⇩∘ f"
using assms by auto
subsubsection‹Converse relation›
definition fconverse :: "V ⇒ V" (‹(_¯⇩∙)› [1000] 999)
where "r¯⇩∙ = set {[b, a]⇩∘ | a b. [a, b]⇩∘ ∈⇩∘ r}"
lemma fconverse_small[simp]: "small {[b, a]⇩∘ | a b. [a, b]⇩∘ ∈⇩∘ r}"
proof-
have eq:
"{[b, a]⇩∘ | a b. [a, b]⇩∘ ∈⇩∘ r} = (λx. [x⦇1⇩ℕ⦈, x⦇0⇩ℕ⦈]⇩∘) ` elts (fpairs r)"
proof(rule subset_antisym; rule subsetI, unfold mem_Collect_eq)
fix x assume "x ∈ (λx. [x⦇1⇩ℕ⦈, x⦇0⇩ℕ⦈]⇩∘) ` elts (fpairs r)"
then obtain a b where "[a, b]⇩∘ ∈⇩∘ fpairs r"
and "x = (λx. [x⦇1⇩ℕ⦈, x⦇0⇩ℕ⦈]⇩∘) [a, b]⇩∘"
by blast
then show "∃a b. x = [b, a]⇩∘ ∧ [a, b]⇩∘ ∈⇩∘ r" by (auto simp: nat_omega_simps)
qed (use image_iff fpairs_iff_elts in ‹fastforce simp: nat_omega_simps›)
show ?thesis unfolding eq by (rule replacement) auto
qed
text‹Rules.›
lemma fconverseI[sym, intro!]:
assumes "[a, b]⇩∘ ∈⇩∘ r"
shows "[b, a]⇩∘ ∈⇩∘ r¯⇩∙"
using assms unfolding fconverse_def by simp
lemma fconverseD[sym, dest]:
assumes "[a, b]⇩∘ ∈⇩∘ r¯⇩∙"
shows "[b, a]⇩∘ ∈⇩∘ r"
using assms unfolding fconverse_def by simp
lemma fconverseE[elim!]:
assumes "x ∈⇩∘ r¯⇩∙"
obtains a b where "x = [b, a]⇩∘" and "[a, b]⇩∘ ∈⇩∘ r"
using assms unfolding fconverse_def by auto
lemma fconverse_iff: "[b, a]⇩∘ ∈⇩∘ r¯⇩∙ ⟷ [a, b]⇩∘ ∈⇩∘ r" by auto
text‹Set operations.›
lemma fconverse_vempty[simp]: "0¯⇩∙ = 0" by auto
lemma fconverse_vsingleton: "(set {[a, b]⇩∘})¯⇩∙ = set {[b, a]⇩∘}" by auto
lemma fconverse_vdoubleton: "(set {[a, b]⇩∘, [c, d]⇩∘})¯⇩∙ = set {[b, a]⇩∘, [d, c]⇩∘}"
by force
lemma fconverse_vinsert: "(vinsert [a, b]⇩∘ r)¯⇩∙ = vinsert [b, a]⇩∘ (r¯⇩∙)" by auto
lemma fconverse_vintersection: "(r ∩⇩∘ s)¯⇩∙ = r¯⇩∙ ∩⇩∘ s¯⇩∙" by auto
lemma fconverse_vunion: "(r ∪⇩∘ s)¯⇩∙ = r¯⇩∙ ∪⇩∘ s¯⇩∙" by auto
text‹Connections.›
lemma fconverse_fid_on[simp]: "(fid_on A)¯⇩∙ = fid_on A" by auto
lemma fconverse_fconst_on[simp]: "(fconst_on A c)¯⇩∙ = set {c} ×⇩∙ A" by blast
lemma fconverse_fcomp: "(r ∘⇩∙ s)¯⇩∙ = s¯⇩∙ ∘⇩∙ r¯⇩∙" by auto
lemma fconverse_ftimes: "(A ×⇩∙ B)¯⇩∙ = (B ×⇩∙ A)" by auto
text‹Special properties.›
lemma fconverse_pred:
assumes "small {[a, b]⇩∘ | a b. P a b}"
shows "(set {[a, b]⇩∘ | a b. P a b})¯⇩∙ = set {[b, a]⇩∘ | a b. P a b}"
using assms unfolding fconverse_def by simp
subsubsection‹Left restriction›
definition flrestriction :: "V ⇒ V ⇒ V" (infixr ‹↾⇧l⇩∙› 80)
where "r ↾⇧l⇩∙ A = set {[a, b]⇩∘ | a b. a ∈⇩∘ A ∧ [a, b]⇩∘ ∈⇩∘ r}"
lemma flrestriction_small[simp]: "small {[a, b]⇩∘ | a b. a ∈⇩∘ A ∧ [a, b]⇩∘ ∈⇩∘ r}"
by (rule down[of _ r]) auto
text‹Rules.›
lemma flrestrictionI[intro!]:
assumes "a ∈⇩∘ A" and "[a, b]⇩∘ ∈⇩∘ r"
shows "[a, b]⇩∘ ∈⇩∘ r ↾⇧l⇩∙ A"
using assms unfolding flrestriction_def by simp
lemma flrestrictionD[dest]:
assumes "[a, b]⇩∘ ∈⇩∘ r ↾⇧l⇩∙ A"
shows "a ∈⇩∘ A" and "[a, b]⇩∘ ∈⇩∘ r"
using assms unfolding flrestriction_def by auto
lemma flrestrictionE[elim!]:
assumes "x ∈⇩∘ r ↾⇧l⇩∙ A"
obtains a b where "x = [a, b]⇩∘" and "a ∈⇩∘ A" and "[a, b]⇩∘ ∈⇩∘ r"
using assms unfolding flrestriction_def by auto
text‹Set operations.›
lemma flrestriction_on_vempty[simp]: "r ↾⇧l⇩∙ 0 = 0" by auto
lemma flrestriction_vempty[simp]: "0 ↾⇧l⇩∙ A = 0" by auto
lemma flrestriction_vsingleton_in[simp]:
assumes "a ∈⇩∘ A"
shows "set {[a, b]⇩∘} ↾⇧l⇩∙ A = set {[a, b]⇩∘}"
using assms by auto
lemma flrestriction_vsingleton_nin[simp]:
assumes "a ∉⇩∘ A"
shows "set {[a, b]⇩∘} ↾⇧l⇩∙ A = 0"
using assms by auto
lemma flrestriction_mono:
assumes "A ⊆⇩∘ B"
shows "r ↾⇧l⇩∙ A ⊆⇩∘ r ↾⇧l⇩∙ B"
using assms by auto
lemma flrestriction_vinsert_nin[simp]:
assumes "a ∉⇩∘ A"
shows "(vinsert [a, b]⇩∘ r) ↾⇧l⇩∙ A = r ↾⇧l⇩∙ A"
using assms by auto
lemma flrestriction_vinsert_in:
assumes "a ∈⇩∘ A"
shows "(vinsert [a, b]⇩∘ r) ↾⇧l⇩∙ A = vinsert [a, b]⇩∘ (r ↾⇧l⇩∙ A)"
using assms by auto
lemma flrestriction_vintersection: "(r ∩⇩∘ s) ↾⇧l⇩∙ A = r ↾⇧l⇩∙ A ∩⇩∘ s ↾⇧l⇩∙ A" by auto
lemma flrestriction_vunion: "(r ∪⇩∘ s) ↾⇧l⇩∙ A = r ↾⇧l⇩∙ A ∪⇩∘ s ↾⇧l⇩∙ A" by auto
lemma flrestriction_vdiff: "(r -⇩∘ s) ↾⇧l⇩∙ A = r ↾⇧l⇩∙ A -⇩∘ s ↾⇧l⇩∙ A" by auto
text‹Connections.›
lemma flrestriction_fid_on[simp]: "(fid_on A) ↾⇧l⇩∙ B = fid_on (A ∩⇩∘ B)" by auto
lemma flrestriction_fconst_on: "(fconst_on A c) ↾⇧l⇩∙ B = (fconst_on B c) ↾⇧l⇩∙ A"
by auto
lemma flrestriction_fconst_on_commute:
assumes "x ∈⇩∘ fconst_on A c ↾⇧l⇩∙ B"
shows "x ∈⇩∘ fconst_on B c ↾⇧l⇩∙ A"
using assms by auto
lemma flrestriction_fcomp[simp]: "(r ∘⇩∙ s) ↾⇧l⇩∙ A = r ∘⇩∙ (s ↾⇧l⇩∙ A)" by auto
text‹Previous connections.›
lemma fcomp_rel_fid_on[simp]: "r ∘⇩∙ fid_on A = r ↾⇧l⇩∙ A" by auto
lemma fcomp_fconst_on:
"r ∘⇩∙ (fconst_on A c) = (r ↾⇧l⇩∙ set {c}) ∘⇩∙ (fconst_on A c)"
by auto
text‹Special properties.›
lemma flrestriction_vsubset_fpairs: "r ↾⇧l⇩∙ A ⊆⇩∘ fpairs r"
by (rule vsubsetI) (metis fpairs_iff_elts flrestrictionE)
lemma flrestriction_vsubset_frel: "r ↾⇧l⇩∙ A ⊆⇩∘ r" by auto
subsubsection‹Right restriction›
definition frrestriction :: "V ⇒ V ⇒ V" (infixr ‹↾⇧r⇩∙› 80)
where "r ↾⇧r⇩∙ A = set {[a, b]⇩∘ | a b. b ∈⇩∘ A ∧ [a, b]⇩∘ ∈⇩∘ r}"
lemma frrestriction_small[simp]: "small {[a, b]⇩∘ | a b. b ∈⇩∘ A ∧ [a, b]⇩∘ ∈⇩∘ r}"
by (rule down[of _ r]) auto
text‹Rules.›
lemma frrestrictionI[intro!]:
assumes "b ∈⇩∘ A" and "[a, b]⇩∘ ∈⇩∘ r"
shows "[a, b]⇩∘ ∈⇩∘ r ↾⇧r⇩∙ A"
using assms unfolding frrestriction_def by simp
lemma frrestrictionD[dest]:
assumes "[a, b]⇩∘ ∈⇩∘ r ↾⇧r⇩∙ A"
shows "b ∈⇩∘ A" and "[a, b]⇩∘ ∈⇩∘ r"
using assms unfolding frrestriction_def by auto
lemma frrestrictionE[elim!]:
assumes "x ∈⇩∘ r ↾⇧r⇩∙ A"
obtains a b where "x = [a, b]⇩∘" and "b ∈⇩∘ A" and "[a, b]⇩∘ ∈⇩∘ r"
using assms unfolding frrestriction_def by auto
text‹Set operations.›
lemma frrestriction_on_vempty[simp]: "r ↾⇧r⇩∙ 0 = 0" by auto
lemma frrestriction_vempty[simp]: "0 ↾⇧r⇩∙ A = 0" by auto
lemma frrestriction_vsingleton_in[simp]:
assumes "b ∈⇩∘ A"
shows "set {[a, b]⇩∘} ↾⇧r⇩∙ A = set {[a, b]⇩∘}"
using assms by auto
lemma frrestriction_vsingleton_nin[simp]:
assumes "b ∉⇩∘ A"
shows "set {[a, b]⇩∘} ↾⇧r⇩∙ A = 0"
using assms by auto
lemma frrestriction_mono:
assumes "A ⊆⇩∘ B"
shows "r ↾⇧r⇩∙ A ⊆⇩∘ r ↾⇧r⇩∙ B"
using assms by auto
lemma frrestriction_vinsert_nin[simp]:
assumes "b ∉⇩∘ A"
shows "(vinsert [a, b]⇩∘ r) ↾⇧r⇩∙ A = r ↾⇧r⇩∙ A"
using assms by auto
lemma frrestriction_vinsert_in:
assumes "b ∈⇩∘ A"
shows "(vinsert [a, b]⇩∘ r) ↾⇧r⇩∙ A = vinsert [a, b]⇩∘ (r ↾⇧r⇩∙ A)"
using assms by auto
lemma frrestriction_vintersection: "(r ∩⇩∘ s) ↾⇧r⇩∙ A = r ↾⇧r⇩∙ A ∩⇩∘ s ↾⇧r⇩∙ A" by auto
lemma frrestriction_vunion: "(r ∪⇩∘ s) ↾⇧r⇩∙ A = r ↾⇧r⇩∙ A ∪⇩∘ s ↾⇧r⇩∙ A" by auto
lemma frrestriction_vdiff: "(r -⇩∘ s) ↾⇧r⇩∙ A = r ↾⇧r⇩∙ A -⇩∘ s ↾⇧r⇩∙ A" by auto
text‹Connections.›
lemma frrestriction_fid_on[simp]: "(fid_on A) ↾⇧r⇩∙ B = fid_on (A ∩⇩∘ B)" by auto
lemma frrestriction_fconst_on:
assumes "c ∈⇩∘ B"
shows "(fconst_on A c) ↾⇧r⇩∙ B = fconst_on A c"
using assms by auto
lemma frrestriction_fcomp[simp]: "(r ∘⇩∙ s) ↾⇧r⇩∙ A = (r ↾⇧r⇩∙ A) ∘⇩∙ s" by auto
text‹Previous connections.›
lemma fcomp_fid_on_rel[simp]: "fid_on A ∘⇩∙ r = r ↾⇧r⇩∙ A" by force
lemma fcomp_fconst_on_rel: "(fconst_on A c) ∘⇩∙ r = (fconst_on A c) ∘⇩∙ (r ↾⇧r⇩∙ A)"
by auto
lemma flrestriction_fconverse: "r¯⇩∙ ↾⇧l⇩∙ A = (r ↾⇧r⇩∙ A)¯⇩∙" by auto
lemma frrestriction_fconverse: "r¯⇩∙ ↾⇧r⇩∙ A = (r ↾⇧l⇩∙ A)¯⇩∙" by auto
text‹Special properties.›
lemma frrestriction_vsubset_rel: "r ↾⇧r⇩∙ A ⊆⇩∘ r" by auto
lemma frrestriction_vsubset_vpairs: "r ↾⇧r⇩∙ A ⊆⇩∘ fpairs r" by auto
subsubsection‹Restriction›
definition frestriction :: "V ⇒ V ⇒ V" (infixr ‹↾⇩∙› 80)
where "r ↾⇩∙ A = set {[a, b]⇩∘ | a b. a ∈⇩∘ A ∧ b ∈⇩∘ A ∧ [a, b]⇩∘ ∈⇩∘ r}"
lemma frestriction_small[simp]:
"small {[a, b]⇩∘ | a b. a ∈⇩∘ A ∧ b ∈⇩∘ A ∧ [a, b]⇩∘ ∈⇩∘ r}"
by (rule down[of _ r]) auto
text‹Rules.›
lemma frestrictionI[intro!]:
assumes "a ∈⇩∘ A" and "b ∈⇩∘ A" and "[a, b]⇩∘ ∈⇩∘ r"
shows "[a, b]⇩∘ ∈⇩∘ r ↾⇩∙ A"
using assms unfolding frestriction_def by simp
lemma frestrictionD[dest]:
assumes "[a, b]⇩∘ ∈⇩∘ r ↾⇩∙ A"
shows "a ∈⇩∘ A" and "b ∈⇩∘ A" and "[a, b]⇩∘ ∈⇩∘ r"
using assms unfolding frestriction_def by auto
lemma frestrictionE[elim!]:
assumes "x ∈⇩∘ r ↾⇩∙ A"
obtains a b where "x = [a, b]⇩∘" and "a ∈⇩∘ A" and "b ∈⇩∘ A" and "[a, b]⇩∘ ∈⇩∘ r"
using assms unfolding frestriction_def by clarsimp
text‹Set operations.›
lemma frestriction_on_vempty[simp]: "r ↾⇩∙ 0 = 0" by auto
lemma frestriction_vempty[simp]: "0 ↾⇩∙ A = 0" by auto
lemma frestriction_vsingleton_in[simp]:
assumes "a ∈⇩∘ A" and "b ∈⇩∘ A"
shows "set {[a, b]⇩∘} ↾⇩∙ A = set {[a, b]⇩∘}"
using assms by auto
lemma frestriction_vsingleton_nin_left[simp]:
assumes "a ∉⇩∘ A"
shows "set {[a, b]⇩∘} ↾⇩∙ A = 0"
using assms by auto
lemma frestriction_vsingleton_nin_right[simp]:
assumes "b ∉⇩∘ A"
shows "set {[a, b]⇩∘} ↾⇩∙ A = 0"
using assms by auto
lemma frestriction_mono:
assumes "A ⊆⇩∘ B"
shows "r ↾⇩∙ A ⊆⇩∘ r ↾⇩∙ B"
using assms by auto
lemma frestriction_vinsert_nin[simp]:
assumes "a ∉⇩∘ A" and "b ∉⇩∘ A"
shows "(vinsert [a, b]⇩∘ r) ↾⇩∙ A = r ↾⇩∙ A"
using assms by auto
lemma frestriction_vinsert_in:
assumes "a ∈⇩∘ A" and "b ∈⇩∘ A"
shows "(vinsert [a, b]⇩∘ r) ↾⇩∙ A = vinsert [a, b]⇩∘ (r ↾⇩∙ A)"
using assms by auto
lemma frestriction_vintersection: "(r ∩⇩∘ s) ↾⇩∙ A = r ↾⇩∙ A ∩⇩∘ s ↾⇩∙ A" by auto
lemma frestriction_vunion: "(r ∪⇩∘ s) ↾⇩∙ A = r ↾⇩∙ A ∪⇩∘ s ↾⇩∙ A" by auto
lemma frestriction_vdiff: "(r -⇩∘ s) ↾⇩∙ A = r ↾⇩∙ A -⇩∘ s ↾⇩∙ A" by auto
text‹Connections.›
lemma fid_on_frestriction[simp]: "(fid_on A) ↾⇩∙ B = fid_on (A ∩⇩∘ B)" by auto
lemma frestriction_fconst_on_ex:
assumes "c ∈⇩∘ B"
shows "(fconst_on A c) ↾⇩∙ B = fconst_on (A ∩⇩∘ B) c"
using assms by auto
lemma frestriction_fconst_on_nex:
assumes "c ∉⇩∘ B"
shows "(fconst_on A c) ↾⇩∙ B = 0"
using assms by auto
lemma frestriction_fcomp[simp]: "(r ∘⇩∙ s) ↾⇩∙ A = (r ↾⇧r⇩∙ A) ∘⇩∙ (s ↾⇧l⇩∙ A)" by auto
lemma frestriction_fconverse: "r¯⇩∙ ↾⇩∙ A = (r ↾⇩∙ A)¯⇩∙" by auto
text‹Previous connections.›
lemma frrestriction_flrestriction[simp]: "(r ↾⇧r⇩∙ A) ↾⇧l⇩∙ A = r ↾⇩∙ A" by auto
lemma flrestriction_frrestriction[simp]: "(r ↾⇧l⇩∙ A) ↾⇧r⇩∙ A = r ↾⇩∙ A" by auto
lemma frestriction_flrestriction[simp]: "(r ↾⇩∙ A) ↾⇧l⇩∙ A = r ↾⇩∙ A" by auto
lemma frestriction_frrestriction[simp]: "(r ↾⇩∙ A) ↾⇧r⇩∙ A = r ↾⇩∙ A" by auto
text‹Special properties.›
lemma frestriction_vsubset_fpairs: "r ↾⇩∙ A ⊆⇩∘ fpairs r" by auto
lemma frestriction_vsubset_ftimes: "r ↾⇩∙ A ⊆⇩∘ A ^⇩× 2⇩ℕ" by force
lemma frestriction_vsubset_rel: "r ↾⇩∙ A ⊆⇩∘ r" by auto
subsection‹Properties›
subsubsection‹Domain›
definition fdomain :: "V ⇒ V" (‹𝒟⇩∙›)
where "𝒟⇩∙ r = set {a. ∃b. [a, b]⇩∘ ∈⇩∘ r}"
notation fdomain (‹𝒟⇩∙›)
lemma fdomain_small[simp]: "small {a. ∃b. [a, b]⇩∘ ∈⇩∘ r}"
proof-
have ss: "{a. ∃b. [a, b]⇩∘ ∈⇩∘ r} ⊆ (λx. x⦇0⇩ℕ⦈) ` elts r"
using image_iff by force
have small: "small ((λx. x⦇0⇩ℕ⦈) ` elts r)" by (rule replacement) simp
show ?thesis by (rule smaller_than_small, rule small, rule ss)
qed
text‹Rules.›
lemma fdomainI[intro]:
assumes "[a, b]⇩∘ ∈⇩∘ r"
shows "a ∈⇩∘ 𝒟⇩∙ r"
using assms unfolding fdomain_def by auto
lemma fdomainD[dest]:
assumes "a ∈⇩∘ 𝒟⇩∙ r"
shows "∃b. [a, b]⇩∘ ∈⇩∘ r"
using assms unfolding fdomain_def by auto
lemma fdomainE[elim]:
assumes "a ∈⇩∘ 𝒟⇩∙ r"
obtains b where "[a, b]⇩∘ ∈⇩∘ r"
using assms unfolding fdomain_def by clarsimp
lemma fdomain_iff: "a ∈⇩∘ 𝒟⇩∙ r ⟷ (∃y. [a, y]⇩∘ ∈⇩∘ r)" by auto
text‹Set operations.›
lemma fdomain_vempty[simp]: "𝒟⇩∙ 0 = 0" by force
lemma fdomain_vsingleton[simp]: "𝒟⇩∙ (set {[a, b]⇩∘}) = set {a}" by auto
lemma fdomain_vdoubleton[simp]: "𝒟⇩∙ (set {[a, b]⇩∘, [c, d]⇩∘}) = set {a, c}"
by force
lemma fdomain_mono:
assumes "r ⊆⇩∘ s"
shows "𝒟⇩∙ r ⊆⇩∘ 𝒟⇩∙ s"
using assms by blast
lemma fdomain_vinsert[simp]: "𝒟⇩∙ (vinsert [a, b]⇩∘ r) = vinsert a (𝒟⇩∙ r)"
by force
lemma fdomain_vunion: "𝒟⇩∙ (A ∪⇩∘ B) = 𝒟⇩∙ A ∪⇩∘ 𝒟⇩∙ B" by force
lemma fdomain_vintersection_vsubset: "𝒟⇩∙ (A ∩⇩∘ B) ⊆⇩∘ 𝒟⇩∙ A ∩⇩∘ 𝒟⇩∙ B" by auto
lemma fdomain_vdiff_vsubset: "𝒟⇩∙ A -⇩∘ 𝒟⇩∙ B ⊆⇩∘ 𝒟⇩∙ (A -⇩∘ B)" by auto
text‹Connections.›
lemma fdomain_fid_on[simp]: "𝒟⇩∙ (fid_on A) = A" by force
lemma fdomain_fconst_on[simp]: "𝒟⇩∙ (fconst_on A c) = A" by force
lemma fdomain_flrestriction: "𝒟⇩∙ (r ↾⇧l⇩∙ A) = 𝒟⇩∙ r ∩⇩∘ A" by auto
text‹Special properties.›
lemma fdomain_vsubset_ftimes:
assumes "fpairs r ⊆⇩∘ A ×⇩∙ B"
shows "𝒟⇩∙ r ⊆⇩∘ A"
using assms by blast
lemma fdomain_vsubset_VUnion2: "𝒟⇩∙ r ⊆⇩∘ ⋃⇩∘(⋃⇩∘(⋃⇩∘r))"
proof(intro vsubsetI)
fix x assume "x ∈⇩∘ 𝒟⇩∙ r"
then obtain y where "[x, y]⇩∘ ∈⇩∘ r" by auto
then have "set {⟨0⇩ℕ, x⟩, ⟨1⇩ℕ, y⟩} ∈⇩∘ r" unfolding vcons_vdoubleton by simp
with insert_commute have "⟨0⇩ℕ, x⟩ ∈⇩∘ ⋃⇩∘r" by auto
then show "x ∈⇩∘ ⋃⇩∘(⋃⇩∘(⋃⇩∘r))"
unfolding vpair_def
by (metis (full_types) VUnion_iff insert_commute vintersection_vdoubleton)
qed
subsubsection‹Range›
definition frange :: "V ⇒ V" (‹ℛ⇩∙›)
where "frange r = set {b. ∃a. [a, b]⇩∘ ∈⇩∘ r}"
notation frange (‹ℛ⇩∙›)
lemma frange_small[simp]: "small {b. ∃a. [a, b]⇩∘ ∈⇩∘ r}"
proof-
have ss: "{b. ∃a. [a, b]⇩∘ ∈⇩∘ r} ⊆ (λx. x⦇1⇩ℕ⦈) ` elts r"
using image_iff by (fastforce simp: nat_omega_simps)
have small: "small ((λx. x⦇1⇩ℕ⦈) ` elts r)" by (rule replacement) simp
show ?thesis by (rule smaller_than_small, rule small, rule ss)
qed
text‹Rules.›
lemma frangeI[intro]:
assumes "[a, b]⇩∘ ∈⇩∘ r"
shows "b ∈⇩∘ ℛ⇩∙ r"
using assms unfolding frange_def by auto
lemma frangeD[dest]:
assumes "b ∈⇩∘ ℛ⇩∙ r"
shows "∃a. [a, b]⇩∘ ∈⇩∘ r"
using assms unfolding frange_def by simp
lemma frangeE[elim!]:
assumes "b ∈⇩∘ ℛ⇩∙ r"
obtains a where "[a, b]⇩∘ ∈⇩∘ r"
using assms unfolding frange_def by clarsimp
lemma frange_iff: "b ∈⇩∘ ℛ⇩∙ r ⟷ (∃a. [a, b]⇩∘ ∈⇩∘ r)" by auto
text‹Set operations.›
lemma frange_vempty[simp]: "ℛ⇩∙ 0 = 0" by auto
lemma frange_vsingleton[simp]: "ℛ⇩∙ (set {[a, b]⇩∘}) = set {b}" by auto
lemma frange_vdoubleton[simp]: "ℛ⇩∙ (set {[a, b]⇩∘, [c, d]⇩∘}) = set {b, d}"
by force
lemma frange_mono:
assumes "r ⊆⇩∘ s"
shows "ℛ⇩∙ r ⊆⇩∘ ℛ⇩∙ s"
using assms by force
lemma frange_vinsert[simp]: "ℛ⇩∙ (vinsert [a, b]⇩∘ r) = vinsert b (ℛ⇩∙ r)" by auto
lemma frange_vunion: "ℛ⇩∙ (r ∪⇩∘ s) = ℛ⇩∙ r ∪⇩∘ ℛ⇩∙ s" by auto
lemma frange_vintersection_vsubset: "ℛ⇩∙ (r ∩⇩∘ s) ⊆⇩∘ ℛ⇩∙ r ∩⇩∘ ℛ⇩∙ s" by auto
lemma frange_vdiff_vsubset: "ℛ⇩∙ r -⇩∘ ℛ⇩∙ s ⊆⇩∘ ℛ⇩∙ (r -⇩∘ s)" by auto
text‹Connections.›
lemma frange_fid_on[simp]: "ℛ⇩∙ (fid_on A) = A" by force
lemma frange_fconst_on_vempty[simp]: "ℛ⇩∙ (fconst_on 0 c) = 0" by auto
lemma frange_fconst_on_ne[simp]:
assumes "A ≠ 0"
shows "ℛ⇩∙ (fconst_on A c) = set {c}"
using assms by force
lemma frange_vrrestriction: "ℛ⇩∙ (r ↾⇧r⇩∙ A) = ℛ⇩∙ r ∩⇩∘ A" by auto
text‹Previous connections›
lemma fdomain_fconverse[simp]: "𝒟⇩∙ (r¯⇩∙) = ℛ⇩∙ r" by auto
lemma frange_fconverse[simp]: "ℛ⇩∙ (r¯⇩∙) = 𝒟⇩∙ r" by force
text‹Special properties.›
lemma frange_iff_vdomain: "b ∈⇩∘ ℛ⇩∙ r ⟷ (∃a∈⇩∘𝒟⇩∙ r. [a, b]⇩∘ ∈⇩∘ r)" by auto
lemma frange_vsubset_ftimes:
assumes "fpairs r ⊆⇩∘ A ×⇩∙ B"
shows "ℛ⇩∙ r ⊆⇩∘ B"
using assms by blast
lemma fpairs_vsubset_fdomain_frange[simp]: "fpairs r ⊆⇩∘ (𝒟⇩∙ r) ×⇩∙ (ℛ⇩∙ r)"
by blast
lemma frange_vsubset_VUnion2: "ℛ⇩∙ r ⊆⇩∘ ⋃⇩∘(⋃⇩∘(⋃⇩∘r))"
proof(intro vsubsetI)
fix y assume "y ∈⇩∘ ℛ⇩∙ r"
then obtain x where "[x, y]⇩∘ ∈⇩∘ r" by auto
then have "set {⟨0⇩ℕ, x⟩, ⟨1⇩ℕ, y⟩} ∈⇩∘ r" unfolding vcons_vdoubleton by simp
with insert_commute have "⟨1⇩ℕ, y⟩ ∈⇩∘ ⋃⇩∘r" by auto
then show "y ∈⇩∘ ⋃⇩∘(⋃⇩∘(⋃⇩∘r))"
unfolding vpair_def
by (metis (full_types) VUnion_iff insert_commute vintersection_vdoubleton)
qed
subsubsection‹Field›
definition ffield :: "V ⇒ V"
where "ffield r = 𝒟⇩∙ r ∪⇩∘ ℛ⇩∙ r"
abbreviation app_ffield :: "V ⇒ V" (‹ℱ⇩∙›)
where "ℱ⇩∙ r ≡ ffield r"
text‹Rules.›
lemma ffieldI1[intro]:
assumes "a ∈⇩∘ 𝒟⇩∙ r ∪⇩∘ ℛ⇩∙ r"
shows "a ∈⇩∘ ffield r"
using assms unfolding ffield_def by simp
lemma ffieldI2[intro]:
assumes "[a, b]⇩∘ ∈⇩∘ r"
shows "a ∈⇩∘ ffield r"
using assms by auto
lemma ffieldI3[intro]:
assumes "[a, b]⇩∘ ∈⇩∘ r"
shows "b ∈⇩∘ ffield r"
using assms by auto
lemma ffieldD[intro]:
assumes "a ∈⇩∘ ffield r"
shows "a ∈⇩∘ 𝒟⇩∙ r ∪⇩∘ ℛ⇩∙ r"
using assms unfolding ffield_def by simp
lemma ffieldE[elim]:
assumes "a ∈⇩∘ ffield r" and "a ∈⇩∘ 𝒟⇩∙ r ∪⇩∘ ℛ⇩∙ r ⟹ P"
shows P
using assms by (auto dest: ffieldD)
lemma ffield_pair[elim]:
assumes "a ∈⇩∘ ffield r"
obtains b where "[a, b]⇩∘ ∈⇩∘ r ∨ [b, a]⇩∘ ∈⇩∘ r "
using assms by auto
lemma ffield_iff: "a ∈⇩∘ ffield r ⟷ (∃b. [a, b]⇩∘ ∈⇩∘ r ∨ [b, a]⇩∘ ∈⇩∘ r)" by auto
text‹Set operations.›
lemma ffield_vempty[simp]: "ffield 0 = 0" by force
lemma ffield_vsingleton[simp]: "ffield (set {[a, b]⇩∘}) = set {a, b}" by force
lemma ffield_vdoubleton[simp]:
"ffield (set {[a, b]⇩∘, [c, d]⇩∘}) = set {a, b, c, d}"
by force
lemma ffield_mono:
assumes "r ⊆⇩∘ s"
shows "ffield r ⊆⇩∘ ffield s"
using assms by fastforce
lemma ffield_vinsert[simp]:
"ffield (vinsert [a, b]⇩∘ r) = set {a, b} ∪⇩∘ (ffield r)"
apply (intro vsubset_antisym; intro vsubsetI)
subgoal by auto
subgoal by (metis ffield_iff vinsert_iff vinsert_vinsert)
done
lemma ffield_vunion[simp]: "ffield (r ∪⇩∘ s) = ffield r ∪⇩∘ ffield s"
unfolding ffield_def by auto
text‹Connections.›
lemma fid_on_ffield[simp]: "ffield (fid_on A) = A" by force
lemma fconst_on_ffield_ne[intro, simp]:
assumes "A ≠ 0"
shows "ffield (fconst_on A c) = vinsert c A"
using assms by force
lemma fconst_on_ffield_vempty[simp]: "ffield (fconst_on 0 c) = 0" by auto
lemma ffield_fconverse[simp]: "ffield (r¯⇩∙) = ffield r" by force
text‹Special properties.›
lemma ffield_vsubset_VUnion2: "ℱ⇩∙ r ⊆⇩∘ ⋃⇩∘(⋃⇩∘(⋃⇩∘r))"
using fdomain_vsubset_VUnion2 frange_vsubset_VUnion2 by (auto simp: ffield_def)
subsubsection‹Image›
definition fimage :: "V ⇒ V ⇒ V" (infixr ‹`⇩∙› 90)
where "r `⇩∙ A = ℛ⇩∙ (r ↾⇧l⇩∙ A)"
notation fimage (infixr "`⇩∙" 90)
lemma fimage_small[simp]: "small {b. ∃a∈⇩∘A. [a, b]⇩∘ ∈⇩∘ r}"
proof-
from image_iff ord_of_nat_succ_vempty have ss:
"{b. ∃a∈⇩∘A. [a, b]⇩∘ ∈⇩∘ r} ⊆ (λx. x⦇1⇩ℕ⦈) ` elts r"
by fastforce
have small: "small ((λx. x⦇1⇩ℕ⦈) ` elts r)" by (rule replacement) simp
show ?thesis by (rule smaller_than_small, rule small, rule ss)
qed
text‹Rules.›
lemma fimageI1:
assumes "x ∈⇩∘ ℛ⇩∙ (r ↾⇧l⇩∙ A)"
shows "x ∈⇩∘ r `⇩∙ A"
using assms unfolding fimage_def by simp
lemma fimageI2[intro]:
assumes "[a, b]⇩∘ ∈⇩∘ r" and "a ∈⇩∘ A"
shows "b ∈⇩∘ r `⇩∙ A"
using assms fimageI1 by auto
lemma fimageD[dest]:
assumes "x ∈⇩∘ r `⇩∙ A"
shows "x ∈⇩∘ ℛ⇩∙ (r ↾⇧l⇩∙ A)"
using assms unfolding fimage_def by simp
lemma fimageE[elim]:
assumes "b ∈⇩∘ r `⇩∙ A"
obtains a where "[a, b]⇩∘ ∈⇩∘ r" and "a ∈⇩∘ A"
using assms unfolding fimage_def by auto
lemma fimage_iff: "b ∈⇩∘ r `⇩∙ A ⟷ (∃a∈⇩∘A. [a, b]⇩∘ ∈⇩∘ r)" by auto
text‹Set operations.›
lemma fimage_vempty[simp]: "0 `⇩∙ A = 0" by force
lemma fimage_of_vempty[simp]: "r `⇩∙ 0 = 0" by force
lemma fimage_vsingleton_in[intro, simp]:
assumes "a ∈⇩∘ A"
shows "set {[a, b]⇩∘} `⇩∙ A = set {b}"
using assms by auto
lemma fimage_vsingleton_nin[intro, simp]:
assumes "a ∉⇩∘ A"
shows "set {[a, b]⇩∘} `⇩∙ A = 0"
using assms by auto
lemma fimage_vsingleton_vinsert[intro, simp]:
"set {[a, b]⇩∘} `⇩∙ vinsert a A = set {b}"
by auto
lemma fimage_mono:
assumes "r' ⊆⇩∘ r" and "A' ⊆⇩∘ A"
shows "(r' `⇩∙ A') ⊆⇩∘ (r `⇩∙ A)"
using assms by fastforce
lemma fimage_vinsert: "r `⇩∙ (vinsert a A) = r `⇩∙ set {a} ∪⇩∘ r `⇩∙ A" by auto
lemma fimage_vunion_left: "(r ∪⇩∘ s) `⇩∙ A = r `⇩∙ A ∪⇩∘ s `⇩∙ A" by auto
lemma fimage_vunion_right: "r `⇩∙ (A ∪⇩∘ B) = r `⇩∙ A ∪⇩∘ r `⇩∙ B" by auto
lemma fimage_vintersection: "r `⇩∙ (A ∩⇩∘ B) ⊆⇩∘ r `⇩∙ A ∩⇩∘ r `⇩∙ B" by auto
lemma fimage_vdiff: "r `⇩∙ A -⇩∘ r `⇩∙ B ⊆⇩∘ r `⇩∙ (A -⇩∘ B)" by auto
text‹Special properties.›
lemma fimage_vsingleton_iff[iff]: "b ∈⇩∘ r `⇩∙ set {a} ⟷ [a, b]⇩∘ ∈⇩∘ r" by auto
lemma fimage_is_vempty[iff]: "r `⇩∙ A = 0 ⟷ vdisjnt (𝒟⇩∙ r) A" by fastforce
text‹Connections.›
lemma fid_on_fimage[simp]: "(fid_on A) `⇩∙ B = A ∩⇩∘ B" by force
lemma fimage_fconst_on_ne[simp]:
assumes "B ∩⇩∘ A ≠ 0"
shows "(fconst_on A c) `⇩∙ B = set {c}"
using assms by auto
lemma fimage_fconst_on_vempty[simp]:
assumes "vdisjnt A B"
shows "(fconst_on A c) `⇩∙ B = 0"
using assms by auto
lemma fimage_fconst_on_vsubset_const[simp]: "(fconst_on A c) `⇩∙ B ⊆⇩∘ set {c}"
by auto
lemma fcomp_frange: "ℛ⇩∙ (r ∘⇩∙ s) = r `⇩∙ (ℛ⇩∙ s)" by blast
lemma fcomp_fimage: "(r ∘⇩∙ s) `⇩∙ A = r `⇩∙ (s `⇩∙ A)" by blast
lemma fimage_flrestriction[simp]: "(r ↾⇧l⇩∙ A) `⇩∙ B = r `⇩∙ (A ∩⇩∘ B)" by auto
lemma fimage_frrestriction[simp]: "(r ↾⇧r⇩∙ A) `⇩∙ B = A ∩⇩∘ r `⇩∙ B" by auto
lemma fimage_frestriction[simp]: "(r ↾⇩∙ A) `⇩∙ B = A ∩⇩∘ (r `⇩∙ (A ∩⇩∘ B))" by auto
lemma fimage_fdomain: "r `⇩∙ 𝒟⇩∙ r = ℛ⇩∙ r" by auto
lemma fimage_eq_imp_fcomp:
assumes "f `⇩∙ A = g `⇩∙ B"
shows "(h ∘⇩∙ f) `⇩∙ A = (h ∘⇩∙ g) `⇩∙ B"
using assms by (metis fcomp_fimage)
text‹Previous connections.›
lemma fcomp_rel_fconst_on_ftimes: "r ∘⇩∙ (fconst_on A c) = A ×⇩∙ (r `⇩∙ set {c})"
by blast
text‹Further special properties.›
lemma fimage_vsubset:
assumes "r ⊆⇩∘ A ×⇩∙ B"
shows "r `⇩∙ C ⊆⇩∘ B"
using assms by blast
lemma fimage_set_def: "r `⇩∙ A = set {b. ∃a∈⇩∘A. [a, b]⇩∘ ∈⇩∘ r}"
unfolding fimage_def frange_def by auto
lemma fimage_vsingleton: "r `⇩∙ set {a} = set {b. [a, b]⇩∘ ∈⇩∘ r}"
proof-
have "{b. [a, b]⇩∘ ∈⇩∘ r} ⊆ {b. ∃a. [a, b]⇩∘ ∈⇩∘ r}" by auto
then have [simp]: "small {b. [a, b]⇩∘ ∈⇩∘ r}"
by (rule smaller_than_small[OF frange_small[of r]])
show ?thesis by auto
qed
lemma fimage_strict_vsubset: "f `⇩∙ A ⊆⇩∘ f `⇩∙ 𝒟⇩∙ f" by auto
subsubsection‹Inverse image›
definition finvimage :: "V ⇒ V ⇒ V" (infixr ‹-`⇩∙› 90)
where "r -`⇩∙ A = r¯⇩∙ `⇩∙ A"
lemma finvimage_small[simp]: "small {a. ∃b∈⇩∘A. [a, b]⇩∘ ∈⇩∘ r}"
proof-
have ss: "{a. ∃b∈⇩∘A. [a, b]⇩∘ ∈⇩∘ r} ⊆ (λx. x⦇0⇩ℕ⦈) ` elts r"
using image_iff by fastforce
have small: "small ((λx. x⦇0⇩ℕ⦈) ` elts r)" by (rule replacement) simp
show ?thesis by (rule smaller_than_small, rule small, rule ss)
qed
text‹Rules.›
lemma finvimageI[intro]:
assumes "[a, b]⇩∘ ∈⇩∘ r" and "b ∈⇩∘ A"
shows "a ∈⇩∘ r -`⇩∙ A"
using assms finvimage_def by auto
lemma finvimageD[dest]:
assumes "a ∈⇩∘ r -`⇩∙ A"
shows "a ∈⇩∘ 𝒟⇩∙ (r ↾⇧r⇩∙ A)"
using assms using finvimage_def by auto
lemma finvimageE[elim]:
assumes "a ∈⇩∘ r -`⇩∙ A"
obtains b where "[a, b]⇩∘ ∈⇩∘ r" and "b ∈⇩∘ A"
using assms unfolding finvimage_def by auto
lemma finvimageI1:
assumes "a ∈⇩∘ 𝒟⇩∙ (r ↾⇧r⇩∙ A)"
shows "a ∈⇩∘ r -`⇩∙ A"
using assms unfolding fimage_def
by (simp add: finvimage_def fimageI1 flrestriction_fconverse)
lemma finvimageD1:
assumes "a ∈⇩∘ r -`⇩∙ A"
shows "a ∈⇩∘ 𝒟⇩∙ (r ↾⇧r⇩∙ A)"
using assms by fastforce
lemma finvimageE1:
assumes "a ∈⇩∘ r -`⇩∙ A " and "a ∈⇩∘ 𝒟⇩∙ (r ↾⇧r⇩∙ A) ⟹ P"
shows P
using assms by auto
lemma finvimageI2:
assumes "a ∈⇩∘ r¯⇩∙ `⇩∙ A"
shows "a ∈⇩∘ r -`⇩∙ A"
using assms unfolding finvimage_def by simp
lemma finvimageD2:
assumes "a ∈⇩∘ r -`⇩∙ A"
shows "a ∈⇩∘ r¯⇩∙ `⇩∙ A"
using assms unfolding finvimage_def by simp
lemma finvimageE2:
assumes "a ∈⇩∘ r -`⇩∘ A" and "a ∈⇩∘ r¯⇩∘ `⇩∘ A ⟹ P"
shows P
unfolding vimage_def using assms by blast
lemma finvimage_iff: "a ∈⇩∘ r -`⇩∙ A ⟷ (∃b∈⇩∘A. [a, b]⇩∘ ∈⇩∘ r)" by auto
lemma finvimage_iff1: "a ∈⇩∘ r -`⇩∙ A ⟷ a ∈⇩∘ 𝒟⇩∙ (r ↾⇧r⇩∙ A)" by auto
lemma finvimage_iff2: "a ∈⇩∘ r -`⇩∙ A ⟷ a ∈⇩∘ r¯⇩∙ `⇩∙ A" by auto
text‹Set operations.›
lemma finvimage_vempty[simp]: "0 -`⇩∙ A = 0" by force
lemma finvimage_of_vempty[simp]: "r -`⇩∙ 0 = 0" by force
lemma finvimage_vsingleton_in[intro, simp]:
assumes "b ∈⇩∘ A"
shows "set {[a, b]⇩∘} -`⇩∙ A = set {a}"
using assms by auto
lemma finvimage_vsingleton_nin[intro, simp]:
assumes "b ∉⇩∘ A"
shows "set {[a, b]⇩∘} -`⇩∙ A = 0"
using assms by auto
lemma finvimage_vsingleton_vinsert[intro, simp]:
"set {[a, b]⇩∘} -`⇩∙ vinsert b A = set {a}"
by auto
lemma finvimage_mono:
assumes "r' ⊆⇩∘ r" and "A' ⊆⇩∘ A"
shows "(r' -`⇩∙ A') ⊆⇩∘ (r -`⇩∙ A)"
using assms by fastforce
lemma finvimage_vinsert: "r -`⇩∙ (vinsert a A) = r -`⇩∙ set {a} ∪⇩∘ r -`⇩∙ A" by auto
lemma finvimage_vunion_left: "(r ∪⇩∘ s) -`⇩∙ A = r -`⇩∙ A ∪⇩∘ s -`⇩∙ A" by auto
lemma finvimage_vunion_right: "r -`⇩∙ (A ∪⇩∘ B) = r -`⇩∙ A ∪⇩∘ r -`⇩∙ B" by auto
lemma finvimage_vintersection: "r -`⇩∙ (A ∩⇩∘ B) ⊆⇩∘ r -`⇩∙ A ∩⇩∘ r -`⇩∙ B" by auto
lemma finvimage_vdiff: "r -`⇩∙ A -⇩∘ r -`⇩∙ B ⊆⇩∘ r -`⇩∙ (A -⇩∘ B)" by auto
text‹Special properties.›
lemma finvimage_set_def: "r -`⇩∙ A = set {a. ∃b∈⇩∘A. [a, b]⇩∘ ∈⇩∘ r}" by fastforce
lemma finvimage_eq_fdomain_frestriction: "r -`⇩∙ A = 𝒟⇩∙ (r ↾⇧r⇩∙ A)" by fastforce
lemma finvimage_frange[simp]: "r -`⇩∙ ℛ⇩∙ r = 𝒟⇩∙ r"
unfolding invimage_def by force
lemma finvimage_frange_vsubset[simp]:
assumes "ℛ⇩∙ r ⊆⇩∘ B"
shows "r -`⇩∙ B = 𝒟⇩∙ r"
using assms unfolding finvimage_def by force
text‹Connections.›
lemma finvimage_fid_on[simp]: "(fid_on A) -`⇩∙ B = A ∩⇩∘ B" by force
lemma finvimage_fconst_on_vsubset_fdomain[simp]: "(fconst_on A c) -`⇩∙ B ⊆⇩∘ A"
unfolding finvimage_def by blast
lemma finvimage_fconst_on_ne[simp]:
assumes "c ∈⇩∘ B"
shows "(fconst_on A c) -`⇩∙ B = A"
by (simp add: assms finvimage_eq_fdomain_frestriction frrestriction_fconst_on)
lemma finvimage_fconst_on_vempty[simp]:
assumes "c ∉⇩∘ B"
shows "(fconst_on A c) -`⇩∙ B = 0"
using assms by auto
lemma finvimage_fcomp: "(g ∘⇩∙ f) -`⇩∙ x = f -`⇩∙ (g -`⇩∙ x) "
by (simp add: finvimage_def fconverse_fcomp fcomp_fimage)
lemma finvimage_fconverse[simp]: "r¯⇩∙ -`⇩∙ A = r `⇩∙ A" by auto
lemma finvimage_flrestriction[simp]: "(r ↾⇧l⇩∙ A) -`⇩∙ B = A ∩⇩∘ r -`⇩∙ B" by auto
lemma finvimage_frrestriction[simp]: "(r ↾⇧r⇩∙ A) -`⇩∙ B = (r -`⇩∙ (A ∩⇩∘ B))" by auto
lemma finvimage_frestriction[simp]: "(r ↾⇩∙ A) -`⇩∙ B = A ∩⇩∘ (r -`⇩∙ (A ∩⇩∘ B))"
by blast
text‹Previous connections.›
lemma fdomain_fcomp[simp]: "𝒟⇩∙ (r ∘⇩∙ s) = s -`⇩∙ 𝒟⇩∙ r" by force
subsection‹Classification of relations›
subsubsection‹Binary relation›
locale fbrelation =
fixes r :: V
assumes fbrelation[simp]: "fpairs r = r"
locale fbrelation_pair = r⇩1: fbrelation r⇩1 + r⇩2: fbrelation r⇩2 for r⇩1 r⇩2
text‹Rules.›
lemma fpairs_eqI[intro!]:
assumes "⋀x. x ∈⇩∘ r ⟹ ∃a b. x = [a, b]⇩∘"
shows "fpairs r = r"
using assms by auto
lemma fpairs_eqD[dest]:
assumes "fpairs r = r"
shows "⋀x. x ∈⇩∘ r ⟹ ∃a b. x = [a, b]⇩∘"
using assms by auto
lemma fpairs_eqE[elim!]:
assumes "fpairs r = r" and "(⋀x. x ∈⇩∘ r ⟹ ∃a b. x = [a, b]⇩∘) ⟹ P"
shows P
using assms by auto
lemmas fbrelationI[intro!] = fbrelation.intro
lemmas fbrelationD[dest!] = fbrelation.fbrelation
lemma fbrelationE[elim!]:
assumes "fbrelation r" and "(fpairs r = r) ⟹ P"
shows P
using assms unfolding fbrelation_def by auto
lemma fbrelationE1:
assumes "fbrelation r" and "x ∈⇩∘ r"
obtains a b where "x = [a, b]⇩∘"
using assms by auto
lemma fbrelationD1[dest]:
assumes "fbrelation r" and "x ∈⇩∘ r"
shows "∃a b. x = [a, b]⇩∘"
using assms by auto
text‹Set operations.›
lemma fbrelation_vsubset:
assumes "fbrelation s" and "r ⊆⇩∘ s"
shows "fbrelation r"
using assms by auto
lemma fbrelation_vinsert: "fbrelation (vinsert [a, b]⇩∘ r) ⟷ fbrelation r"
by auto
lemma (in fbrelation) fbrelation_vinsertI: "fbrelation (vinsert [a, b]⇩∘ r)"
using fbrelation_axioms by auto
lemma fbrelation_vinsertD[dest]:
assumes "fbrelation (vinsert ⟨a, b⟩ r)"
shows "fbrelation r"
using assms by auto
lemma fbrelation_vunion: "fbrelation (r ∪⇩∘ s) ⟷ fbrelation r ∧ fbrelation s"
by auto
lemma (in fbrelation_pair) fbrelation_vunionI: "fbrelation (r⇩1 ∪⇩∘ r⇩2)"
using r⇩1.fbrelation_axioms r⇩2.fbrelation_axioms by auto
lemma fbrelation_vunionD[dest]:
assumes "fbrelation (r ∪⇩∘ s)"
shows "fbrelation r" and "fbrelation s"
using assms by auto
lemma (in fbrelation) fbrelation_vintersectionI: "fbrelation (r ∩⇩∘ s)"
using fbrelation_axioms by auto
lemma (in fbrelation) fbrelation_vdiffI: "fbrelation (r -⇩∘ s)"
using fbrelation_axioms by auto
text‹Connections.›
lemma fbrelation_vempty: "fbrelation 0" by auto
lemma fbrelation_vsingleton: "fbrelation (set {[a, b]⇩∘})" by auto
global_interpretation frel_vsingleton: fbrelation ‹set {[a, b]⇩∘}›
by (rule fbrelation_vsingleton)
lemma fbrelation_vdoubleton: "fbrelation (set {[a, b]⇩∘, [c, d]⇩∘})" by auto
lemma fbrelation_sid_on[simp]: "fbrelation (fid_on A)" by auto
lemma fbrelation_fconst_on[simp]: "fbrelation (fconst_on A c)" by auto
lemma (in fbrelation_pair) fbrelation_fcomp: "fbrelation (r⇩1 ∘⇩∙ r⇩2)"
using r⇩1.fbrelation_axioms r⇩2.fbrelation_axioms by auto
sublocale fbrelation_pair ⊆ fcomp⇩2⇩1: fbrelation ‹r⇩2 ∘⇩∙ r⇩1›
by
(
simp add:
fbrelation_pair.fbrelation_fcomp
fbrelation_pair_def
r⇩1.fbrelation_axioms
r⇩2.fbrelation_axioms
)
sublocale fbrelation_pair ⊆ fcomp⇩1⇩2: fbrelation ‹r⇩1 ∘⇩∙ r⇩2›
by (rule fbrelation_fcomp)
lemma (in fbrelation) fbrelation_fconverse: "fbrelation (r¯⇩∙)"
using fbrelation_axioms by clarsimp
lemma fbrelation_flrestriction[intro, simp]: "fbrelation (r ↾⇧l⇩∙ A)" by auto
lemma fbrelation_frrestriction[intro, simp]: "fbrelation (r ↾⇧r⇩∙ A)" by auto
lemma fbrelation_frestriction[intro, simp]: "fbrelation (r ↾⇩∙ A)" by auto
text‹Previous connections.›
lemma (in fbrelation) fconverse_fconverse[simp]: "(r¯⇩∙)¯⇩∙ = r"
using fbrelation_axioms by auto
lemma (in fbrelation_pair) fconverse_mono[simp]: "r⇩1¯⇩∙ ⊆⇩∘ r⇩2¯⇩∙ ⟷ r⇩1 ⊆⇩∘ r⇩2"
using r⇩1.fbrelation_axioms r⇩2.fbrelation_axioms
by (force intro: fconverse_vunion)+
lemma (in fbrelation_pair) fconverse_inject[simp]: "r⇩1¯⇩∙ = r⇩2¯⇩∙ ⟷ r⇩1 = r⇩2"
using r⇩1.fbrelation_axioms r⇩2.fbrelation_axioms by fast
lemma (in fbrelation) fconverse_vsubset_swap_2:
assumes "r¯⇩∙ ⊆⇩∘ s"
shows "r ⊆⇩∘ s¯⇩∙"
using assms fbrelation_axioms by auto
lemma (in fbrelation) flrestriction_fdomain[simp]: "r ↾⇧l⇩∙ 𝒟⇩∙ r = r"
using fbrelation_axioms by (elim fbrelationE) blast
lemma (in fbrelation) frrestriction_frange[simp]: "r ↾⇧r⇩∙ ℛ⇩∙ r = r"
using fbrelation_axioms by (elim fbrelationE) blast
text‹Special properties.›
lemma vsubset_vtimes_fbrelation:
assumes "r ⊆⇩∘ A ×⇩∙ B"
shows "fbrelation r"
using assms by blast
lemma (in fbrelation) fbrelation_vintersection_vdomain:
assumes "vdisjnt (𝒟⇩∙ r) (𝒟⇩∙ s)"
shows "vdisjnt r s"
proof(rule vsubset_antisym; rule vsubsetI)
fix x assume "x ∈⇩∘ r ∩⇩∘ s"
then obtain a b where "[a, b]⇩∘ ∈⇩∘ r ∩⇩∘ s"
by (metis fbrelationE1 fbrelation_vintersectionI)
with assms show "x ∈⇩∘ 0" by auto
qed simp
lemma (in fbrelation) fbrelation_vintersection_vrange:
assumes "vdisjnt (ℛ⇩∙ r) (ℛ⇩∙ s)"
shows "vdisjnt r s"
proof(rule vsubset_antisym; rule vsubsetI)
fix x assume "x ∈⇩∘ r ∩⇩∘ s"
then obtain a b where "[a, b]⇩∘ ∈⇩∘ r ∩⇩∘ s"
by (metis fbrelationE1 fbrelation_vintersectionI)
with assms show "x ∈⇩∘ 0" by auto
qed simp
lemma (in fbrelation) fbrelation_vintersection_vfield:
assumes "vdisjnt (ffield r) (ffield s)"
shows "vdisjnt r s"
proof(rule vsubset_antisym; rule vsubsetI)
fix x assume "x ∈⇩∘ r ∩⇩∘ s"
then obtain a b where "[a, b]⇩∘ ∈⇩∘ r ∩⇩∘ s"
by (metis fbrelationE1 fbrelation_vintersectionI)
with assms show "x ∈⇩∘ 0" by auto
qed auto
lemma (in fbrelation) vdomain_vrange_vtimes: "r ⊆⇩∘ 𝒟⇩∙ r ×⇩∙ ℛ⇩∙ r"
using fbrelation by blast
lemma (in fbrelation) fconverse_eq_frel[intro, simp]:
assumes "⋀a b. [a, b]⇩∘ ∈⇩∘ r ⟹ [b, a]⇩∘ ∈⇩∘ r"
shows "r¯⇩∙ = r"
using assms
apply (intro vsubset_antisym; intro vsubsetI)
subgoal by blast
subgoal by (metis fconverseE fconverseI fconverse_fconverse)
done
lemma fcomp_fconverse_frel_eq_frel_fbrelationI:
assumes "r¯⇩∙ ∘⇩∙ r = r"
shows "fbrelation r"
using assms by (intro fbrelationI, elim vequalityE vsubsetE) force
text‹Alternative forms of existing results.›
lemmas [intro, simp] = fbrelation.fconverse_fconverse
and fconverse_eq_frel[intro, simp] = fbrelation.fconverse_eq_frel
context
fixes r⇩1 r⇩2
assumes r⇩1: "fbrelation r⇩1"
and r⇩2: "fbrelation r⇩2"
begin
lemmas_with[OF fbrelation_pair.intro[OF r⇩1 r⇩2]] :
fbrelation_fconverse_mono[intro, simp] = fbrelation_pair.fconverse_mono
and fbrelation_frrestriction_srange[intro, simp] =
fbrelation_pair.fconverse_inject
end
text‹\newpage›
end
Theory CZH_Sets_VNHS
section‹Further results related to the von Neumann hierarchy of sets›
theory CZH_Sets_VNHS
imports
CZH_Sets_FBRelations
CZH_Sets_Ordinals
begin
subsection‹Background›
text‹
The subsection presents several further auxiliary results about the
von Neumann hierarchy of sets. The primary general reference for this section
is \cite{takeuti_introduction_1971}.
›
subsection‹Further elementary properties of ‹Vfrom››
text‹Reusable patterns.›
lemma Vfrom_Ord_bundle:
assumes "A = A" and "i = i"
shows "Vfrom A i = Vfrom A (rank i)" and "Ord (rank i)"
by (simp_all add: Vfrom_rank_eq )
lemma Vfrom_in_bundle:
assumes "i ∈⇩∘ j" and "A = A" and "B = B"
shows "Vfrom A i = Vfrom A (rank i)"
and "Ord (rank i)"
and "Vfrom B j = Vfrom B (rank j)"
and "Ord (rank j)"
and "rank i ∈⇩∘ rank j"
by (simp_all add: assms(1) Vfrom_rank_eq Ord_mem_iff_lt rank_lt)
text‹Elementary corollaries.›
lemma Ord_Vset_in_Vset_succI[intro]:
assumes "Ord α"
shows "Vset α ∈⇩∘ Vset (succ α)"
by (simp add: Vset_succ assms)
lemma Ord_in_in_VsetI[intro]:
assumes "Ord α" and "a ∈⇩∘ α"
shows "a ∈⇩∘ Vset α"
by (metis assms Ord_VsetI Ord_iff_rank rank_lt)
text‹Transitivity of the constant \<^const>‹Vfrom›.›
lemma Vfrom_trans[intro]:
assumes "Transset A" and "x ∈⇩∘ X" and "X ∈⇩∘ Vfrom A i"
shows "x ∈⇩∘ Vfrom A i"
using Transset_def by (blast intro: assms Transset_Vfrom)
lemma Vset_trans[intro]:
assumes "x ∈⇩∘ X" and "X ∈⇩∘ Vset i"
shows "x ∈⇩∘ Vset i"
by (auto intro: assms)
text‹Monotonicity of the constant \<^const>‹Vfrom›.›
lemma Vfrom_in_mono:
assumes "A ⊆⇩∘ B" and "i ∈⇩∘ j"
shows "Vfrom A i ∈⇩∘ Vfrom B j"
proof-
define i' where "i' = rank i"
define j' where "j' = rank j"
note rank_conv =
Vfrom_in_bundle[
OF assms(2) HOL.refl[of A] HOL.refl[of B], folded i'_def j'_def
]
show ?thesis
unfolding rank_conv using rank_conv(4,5)
proof induction
case (succ j')
from succ have "Ord (succ j')" by auto
from succ(3) succ.hyps have "i' ⊆⇩∘ j'" by (auto simp: Ord_def Transset_def)
from Vfrom_mono[OF ‹Ord i'› assms(1) this] show ?case
unfolding Vfrom_succ_Ord[OF ‹Ord j'›, of B] by simp
next
case (Limit j')
from Limit(3) obtain ξ where "i' ∈⇩∘ ξ" and "ξ ∈⇩∘ j'" by auto
with vifunionI have "Vfrom A i' ∈⇩∘ (⋃⇩∘ξ∈⇩∘j'. Vfrom B ξ)"
by (auto simp: Limit.IH)
then show "Vfrom A i' ∈⇩∘ Vfrom B (⋃⇩∘ξ∈⇩∘j'. ξ)"
unfolding Limit_Vfrom_eq[symmetric, OF Limit(1)]
by (simp add: SUP_vifunion[symmetric] Limit.hyps)
qed auto
qed
lemmas Vset_in_mono = Vfrom_in_mono[OF order_refl, of _ _ 0]
lemma Vfrom_vsubset_mono:
assumes "A ⊆⇩∘ B" and "i ⊆⇩∘ j"
shows "Vfrom A i ⊆⇩∘ Vfrom B j"
by (metis assms Vfrom_Ord_bundle(1,2) Vfrom_mono rank_mono)
lemmas Vset_vsubset_mono = Vfrom_vsubset_mono[OF order_refl, of _ _ 0]
lemma arg1_vsubset_Vfrom: "a ⊆⇩∘ Vfrom a i" using Vfrom by blast
lemma VPow_vsubset_Vset:
assumes "X ∈⇩∘ Vset i"
shows "VPow X ⊆⇩∘ Vset i"
proof-
define i' where "i' = rank i"
note rank_conv = Vfrom_Ord_bundle[OF refl[of 0] refl[of i], folded i'_def]
show ?thesis
using rank_conv(2) assms unfolding rank_conv
proof induction
case (Limit α)
from Limit have "X ∈⇩∘ (⋃⇩∘i∈⇩∘α. Vset i)"
by (simp add: SUP_vifunion[symmetric] Limit_Vfrom_eq)
then have "VPow X ⊆⇩∘ (⋃⇩∘i∈⇩∘α. Vset i)"
by (intro vsubsetI) (metis Limit.IH vifunionE vifunionI vsubsetE)
then show ?case
by (simp add: SUP_vifunion[symmetric] Limit.hyps Limit_Vfrom_eq)
qed (simp_all add: Vset_succ)
qed
lemma Vfrom_vsubset_VPow_Vfrom:
assumes "Transset A"
shows "Vfrom A i ⊆⇩∘ VPow (Vfrom A i)"
using assms Transset_VPow Transset_Vfrom by (auto simp: Transset_def)
lemma arg1_vsubset_VPow_Vfrom:
assumes "Transset A"
shows "A ⊆⇩∘ VPow (Vfrom A i)"
by (meson assms Vfrom_vsubset_VPow_Vfrom arg1_vsubset_Vfrom dual_order.trans)
subsection‹Operations closed with respect to \<^const>‹Vset››
text‹Empty set.›
lemma Limit_vempty_in_VsetI:
assumes "Limit α"
shows "0 ∈⇩∘ Vset α"
using assms by (auto simp: Limit_def)
text‹Subset.›
lemma vsubset_in_VsetI[intro]:
assumes "a ⊆⇩∘ A" and "A ∈⇩∘ Vset i"
shows "a ∈⇩∘ Vset i"
using assms by (auto dest: VPow_vsubset_Vset)
lemma Ord_vsubset_in_Vset_succI:
assumes "Ord α" and "A ⊆⇩∘ Vset α"
shows "A ∈⇩∘ Vset (succ α)"
using assms Ord_Vset_in_Vset_succI by auto
text‹Power set.›
lemma Limit_VPow_in_VsetI[intro]:
assumes "Limit α" and "A ∈⇩∘ Vset α"
shows "VPow A ∈⇩∘ Vset α"
proof-
from assms(1) have "Ord α" by auto
with assms obtain i where "A ∈⇩∘ Vset i" and "i ∈⇩∘ α" and "Ord i"
by (fastforce simp: Ord_in_Ord Limit_Vfrom_eq)
have "Vset i ∈⇩∘ Vset α" by (rule Vset_in_mono) (auto intro: ‹i ∈⇩∘ α›)
from VPow_vsubset_Vset[OF ‹A ∈⇩∘ Vset i›] this show ?thesis
by (rule vsubset_in_VsetI)
qed
lemma VPow_in_Vset_revD:
assumes "VPow A ∈⇩∘ Vset i"
shows "A ∈⇩∘ Vset i"
using assms Vset_trans by blast
lemma Ord_VPow_in_Vset_succI:
assumes "Ord α" and "a ∈⇩∘ Vset α"
shows "VPow a ∈⇩∘ Vset (succ α)"
using VPow_vsubset_Vset[OF assms(2)]
by (auto intro: Ord_Vset_in_Vset_succI[OF assms(1)])
lemma Ord_VPow_in_Vset_succD:
assumes "Ord α" and "VPow a ∈⇩∘ Vset (succ α)"
shows "a ∈⇩∘ Vset α"
using assms by (fastforce dest: Vset_succ)
text‹Union of elements.›
lemma VUnion_in_VsetI[intro]:
assumes "A ∈⇩∘ Vset i"
shows "⋃⇩∘A ∈⇩∘ Vset i"
proof-
define i' where "i' = rank i"
note rank_conv = Vfrom_Ord_bundle[OF refl[of 0] refl[of i], folded i'_def]
from rank_conv(2) assms show ?thesis
unfolding rank_conv
proof induction
case (succ α)
show "⋃⇩∘A ∈⇩∘ Vset (succ α)"
by (metis succ(1,3) VPow_iff VUnion_least Vset_trans Vset_succ)
qed (auto simp: vrange_VLambda vimage_VLambda_vrange_rep Limit_Vfrom_eq)
qed
lemma Limit_VUnion_in_VsetD:
assumes "Limit α" and "⋃⇩∘A ∈⇩∘ Vset α"
shows "A ∈⇩∘ Vset α"
proof-
have "A ⊆⇩∘ VPow (⋃⇩∘A)" by auto
moreover from assms have "VPow (⋃⇩∘A) ∈⇩∘ Vset α" by (rule Limit_VPow_in_VsetI)
ultimately show ?thesis using assms(1) by auto
qed
text‹Intersection of elements.›
lemma VInter_in_VsetI[intro]:
assumes "A ∈⇩∘ Vset α"
shows "⋂⇩∘A ∈⇩∘ Vset α"
proof-
have subset: "⋂⇩∘A ⊆⇩∘ ⋃⇩∘A" by auto
moreover from assms have "⋃⇩∘A ∈⇩∘ Vset α" by (rule VUnion_in_VsetI)
ultimately show ?thesis by (rule vsubset_in_VsetI)
qed
text‹Singleton.›
lemma Limit_vsingleton_in_VsetI[intro]:
assumes "Limit α" and "a ∈⇩∘ Vset α"
shows "set {a} ∈⇩∘ Vset α"
proof-
have aa: "set {a} ⊆⇩∘ VPow a" by auto
from assms(1) have "Ord α" by auto
from vsubset_in_VsetI[OF aa Limit_VPow_in_VsetI[OF assms(1)]] show ?thesis
by (simp add: Limit_is_Ord assms(2))
qed
lemma Limit_vsingleton_in_VsetD:
assumes "set {a} ∈⇩∘ Vset α"
shows "a ∈⇩∘ Vset α"
using assms by auto
lemma Ord_vsingleton_in_Vset_succI:
assumes "Ord α" and "a ∈⇩∘ Vset α"
shows "set {a} ∈⇩∘ Vset (succ α)"
using assms by (simp add: Vset_succ vsubset_vsingleton_leftI)
text‹Doubleton.›
lemma Limit_vdoubleton_in_VsetI[intro]:
assumes "Limit α" and "a ∈⇩∘ Vset α" and "b ∈⇩∘ Vset α"
shows "set {a, b} ∈⇩∘ Vset α"
proof-
from assms(1) have "Ord α" by auto
from assms have "a ∈⇩∘ (⋃⇩∘ξ∈⇩∘α. Vset ξ)" and "b ∈⇩∘ (⋃⇩∘ξ∈⇩∘α. Vset ξ)"
by (simp_all add: SUP_vifunion[symmetric] Limit_Vfrom_eq)
then obtain A B
where a: "a ∈⇩∘ Vset A" and "A ∈⇩∘ α" and b: "b ∈⇩∘ Vset B" and "B ∈⇩∘ α"
by blast
moreover with assms have "Ord A" and "Ord B" by auto
ultimately have "A ∪⇩∘ B ∈⇩∘ α"
by (metis Ord_linear_le le_iff_sup sup.order_iff)
then have "Vset (A ∪⇩∘ B) ∈⇩∘ Vset α"
by (simp add: assms Limit_is_Ord Vset_in_mono)
moreover from a b have "set {a, b} ⊆⇩∘ Vset (A ∪⇩∘ B)"
by (simp add: Vfrom_sup vsubset_vdoubleton_leftI)
ultimately show "set {a, b} ∈⇩∘ Vset α" by (rule vsubset_in_VsetI[rotated 1])
qed
lemma vdoubleton_in_VsetD:
assumes "set {a, b} ∈⇩∘ Vset α"
shows "a ∈⇩∘ Vset α" and "b ∈⇩∘ Vset α"
using assms by (auto intro!: Vset_trans[of _ ‹set {a, b}›])
lemma Ord_vdoubleton_in_Vset_succI:
assumes "Ord α" and "a ∈⇩∘ Vset α" and "b ∈⇩∘ Vset α"
shows "set {a, b} ∈⇩∘ Vset (succ α)"
by
(
meson
assms Ord_Vset_in_Vset_succI vsubset_in_VsetI vsubset_vdoubleton_leftI
)
text‹Pairwise union.›
lemma vunion_in_VsetI[intro]:
assumes "a ∈⇩∘ Vset i" and "b ∈⇩∘ Vset i"
shows "a ∪⇩∘ b ∈⇩∘ Vset i"
proof-
define i' where "i' = rank i"
note rank_conv = Vfrom_Ord_bundle[OF refl[of 0] refl[of i], folded i'_def]
show ?thesis
using rank_conv(2) assms unfolding rank_conv
proof induction
case (Limit α)
from Limit have "set {a, b} ∈⇩∘ Vset α"
by (intro Limit_vdoubleton_in_VsetI; unfold SUP_vifunion[symmetric])
simp_all
then have "⋃⇩∘(set {a, b}) ∈⇩∘ Vset α" by (blast intro: Limit.hyps)
with Limit.hyps VUnion_vdoubleton have "a ∪⇩∘ b ∈⇩∘ (⋃⇩∘ξ∈⇩∘α. Vset ξ)"
by (auto simp: Limit_Vfrom_eq)
then show "a ∪⇩∘ b ∈⇩∘ Vset (⋃⇩∘ξ∈⇩∘α. ξ)"
by (simp add: ‹Limit α› Limit_Vfrom_eq)
qed (auto simp add: Vset_succ)
qed
lemma vunion_in_VsetD:
assumes "a ∪⇩∘ b ∈⇩∘ Vset α"
shows "a ∈⇩∘ Vset α" and "b ∈⇩∘ Vset α"
using assms by (meson vsubset_in_VsetI inf_sup_ord(3,4))+
text‹Pairwise intersection.›
lemma vintersection_in_VsetI[intro]:
assumes "a ∈⇩∘ Vset α" and "b ∈⇩∘ Vset α"
shows "a ∩⇩∘ b ∈⇩∘ Vset α"
using assms by (meson vsubset_in_VsetI inf_sup_ord(2))
text‹Set difference.›
lemma vdiff_in_VsetI[intro]:
assumes "a ∈⇩∘ Vset α" and "b ∈⇩∘ Vset α"
shows "a -⇩∘ b ∈⇩∘ Vset α"
using assms by auto
text‹\<^const>‹vinsert›.›
lemma vinsert_in_VsetI[intro]:
assumes "Limit α" and "a ∈⇩∘ Vset α" and "b ∈⇩∘ Vset α"
shows "vinsert a b ∈⇩∘ Vset α"
proof-
have ab: "vinsert a b = set {a} ∪⇩∘ b" by simp
from assms(2) have "set {a} ∈⇩∘ Vset α"
by (simp add: Limit_vsingleton_in_VsetI assms(1))
from this assms(1,3) show "vinsert a b ∈⇩∘ Vset α"
unfolding ab by blast
qed
lemma vinsert_in_Vset_succI[intro]:
assumes "Ord α" and "a ∈⇩∘ Vset α" and "b ∈⇩∘ Vset α"
shows "vinsert a b ∈⇩∘ Vset (succ α)"
using assms by blast
lemma vinsert_in_Vset_succI'[intro]:
assumes "Ord α" and "a ∈⇩∘ Vset α" and "b ∈⇩∘ Vset (succ α)"
shows "vinsert a b ∈⇩∘ Vset (succ α)"
proof-
have ab: "vinsert a b = set {a} ∪⇩∘ b" by simp
show ?thesis
unfolding ab by (intro vunion_in_VsetI Ord_vsingleton_in_Vset_succI assms)
qed
lemma vinsert_in_VsetD:
assumes "vinsert a b ∈⇩∘ Vset α"
shows "a ∈⇩∘ Vset α" and "b ∈⇩∘ Vset α"
using assms Vset_trans by blast+
lemma Limit_insert_in_VsetI:
assumes [intro]: "Limit α"
and [simp]: "small x"
and "set x ∈⇩∘ Vset α"
and [intro]: "a ∈⇩∘ Vset α"
shows "set (insert a x) ∈⇩∘ Vset α"
proof-
have ax: "set (insert a x) = vinsert a (set x)" by auto
from assms show ?thesis unfolding ax by auto
qed
text‹Pair.›
lemma Limit_vpair_in_VsetI[intro]:
assumes "Limit α" and "a ∈⇩∘ Vset α" and "b ∈⇩∘ Vset α"
shows "⟨a, b⟩ ∈⇩∘ Vset α"
using assms Limit_vdoubleton_in_VsetI Limit_vsingleton_in_VsetI
unfolding vpair_def
by simp
lemma vpair_in_VsetD[intro]:
assumes "⟨a, b⟩ ∈⇩∘ Vset α"
shows "a ∈⇩∘ Vset α" and "b ∈⇩∘ Vset α"
using assms unfolding vpair_def by (meson vdoubleton_in_VsetD)+
text‹Cartesian product.›
lemma Limit_vtimes_in_VsetI[intro]:
assumes "Limit α" and "A ∈⇩∘ Vset α" and "B ∈⇩∘ Vset α"
shows "A ×⇩∘ B ∈⇩∘ Vset α"
proof-
from assms(1) have "Ord α" by auto
have "VPow (VPow (A ∪⇩∘ B)) ∈⇩∘ Vset α"
by (simp add: assms Limit_VPow_in_VsetI Limit_is_Ord vunion_in_VsetI)
from assms(1) vsubset_in_VsetI[OF vtimes_vsubset_VPowVPow this] show ?thesis
by auto
qed
text‹Binary relations.›
lemma (in vbrelation) vbrelation_Limit_in_VsetI[intro]:
assumes "Limit α" and "𝒟⇩∘ r ∈⇩∘ Vset α" and "ℛ⇩∘ r ∈⇩∘ Vset α"
shows "r ∈⇩∘ Vset α"
using assms vdomain_vrange_vtimes by auto
lemma
assumes "r ∈⇩∘ Vset α"
shows vdomain_in_VsetI: "𝒟⇩∘ r ∈⇩∘ Vset α"
and vrange_in_VsetI: "ℛ⇩∘ r ∈⇩∘ Vset α"
and vfield_in_VsetI: "ℱ⇩∘ r ∈⇩∘ Vset α"
proof-
from assms have "⋃⇩∘r ∈⇩∘ Vset α" by auto
with assms(1) have r: "⋃⇩∘(⋃⇩∘r) ∈⇩∘ Vset α" by blast
from r assms(1) vfield_vsubset_VUnion2 show "ℱ⇩∘ r ∈⇩∘ Vset α" by auto
from r assms(1) vdomain_vsubset_VUnion2 vrange_vsubset_VUnion2 show
"𝒟⇩∘ r ∈⇩∘ Vset α" "ℛ⇩∘ r ∈⇩∘ Vset α"
by auto
qed
lemma (in vbrelation) vbrelation_Limit_vsubset_VsetI:
assumes "Limit α" and "𝒟⇩∘ r ⊆⇩∘ Vset α" and "ℛ⇩∘ r ⊆⇩∘ Vset α"
shows "r ⊆⇩∘ Vset α"
proof(intro vsubsetI)
fix x assume "x ∈⇩∘ r"
moreover then obtain a b where x_def: "x = ⟨a, b⟩" by (elim vbrelation_vinE)
ultimately have "a ∈⇩∘ 𝒟⇩∘ r" and "b ∈⇩∘ ℛ⇩∘ r" by auto
with assms show "x ∈⇩∘ Vset α" unfolding x_def by auto
qed
lemma
assumes "r ∈⇩∘ Vset α"
shows fdomain_in_VsetI: "𝒟⇩∙ r ∈⇩∘ Vset α"
and frange_in_VsetI: "ℛ⇩∙ r ∈⇩∘ Vset α"
and ffield_in_VsetI: "ℱ⇩∙ r ∈⇩∘ Vset α"
proof-
from assms have "⋃⇩∘r ∈⇩∘ Vset α" by auto
with assms have r: "⋃⇩∘(⋃⇩∘(⋃⇩∘r)) ∈⇩∘ Vset α" by blast
from r assms(1) fdomain_vsubset_VUnion2 frange_vsubset_VUnion2 show
"𝒟⇩∙ r ∈⇩∘ Vset α" "ℛ⇩∙ r ∈⇩∘ Vset α"
by auto
from r assms(1) ffield_vsubset_VUnion2 show "ℱ⇩∙ r ∈⇩∘ Vset α" by auto
qed
lemma (in vsv) vsv_Limit_vrange_in_VsetI[intro]:
assumes "Limit α" and "ℛ⇩∘ r ⊆⇩∘ Vset α" and "vfinite (𝒟⇩∘ r)"
shows "ℛ⇩∘ r ∈⇩∘ Vset α"
using assms(3,1,2) vsv_axioms
proof(induction ‹𝒟⇩∘ r› arbitrary: r rule: vfinite_induct)
case vempty
interpret r': vsv r by (rule vempty(4))
from vempty(1) r'.vlrestriction_vdomain have "r = 0" by simp
from Vset_in_mono vempty.prems(1) show ?case
unfolding ‹r = 0› by (auto simp: Limit_def)
next
case (vinsert x F)
interpret r': vsv r by (rule vinsert(7))
have RrF_Rr: "ℛ⇩∘ (r ↾⇧l⇩∘ F) ⊆⇩∘ ℛ⇩∘ r" by auto
have F_DrF: "F = 𝒟⇩∘ (r ↾⇧l⇩∘ F)"
unfolding vdomain_vlrestriction vinsert(4)[symmetric] by auto
moreover note assms(1)
moreover from RrF_Rr vinsert(6) have "ℛ⇩∘ (r ↾⇧l⇩∘ F) ⊆⇩∘ Vset α" by auto
moreover have "vsv (r ↾⇧l⇩∘ F)" by simp
ultimately have RrF_Vα: "ℛ⇩∘ (r ↾⇧l⇩∘ F) ∈⇩∘ Vset α" by (rule vinsert(3))
have "ℛ⇩∘ r = vinsert (r⦇x⦈) (ℛ⇩∘ (r ↾⇧l⇩∘ F))"
proof(intro vsubset_antisym vsubsetI)
fix b assume "b ∈⇩∘ ℛ⇩∘ r"
then obtain a where "a ∈⇩∘ 𝒟⇩∘ r" and b_def: "b = r⦇a⦈" by force
with vinsert.hyps(4) have "a = x ∨ a ∈⇩∘ F" by auto
with ‹a ∈⇩∘ 𝒟⇩∘ r› show "b ∈⇩∘ vinsert (r⦇x⦈) (ℛ⇩∘ (r ↾⇧l⇩∘ F))"
unfolding b_def by (blast dest: r'.vsv_vimageI1)
next
fix b assume "b ∈⇩∘ vinsert (r⦇x⦈) (ℛ⇩∘ (r ↾⇧l⇩∘ F))"
with RrF_Rr r'.vsv_axioms vinsert.hyps(4) show "b ∈⇩∘ ℛ⇩∘ r" by auto
qed
moreover with vinsert.prems(2) have "r⦇x⦈ ∈⇩∘ Vset α" by auto
moreover have "ℛ⇩∘ (r ↾⇧l⇩∘ F) ∈⇩∘ Vset α" by (blast intro: RrF_Vα)
ultimately show "ℛ⇩∘ r ∈⇩∘ Vset α"
by (simp add: vinsert.prems(1) vinsert_in_VsetI)
qed
lemma (in vsv) vsv_Limit_vsv_in_VsetI[intro]:
assumes "Limit α"
and "𝒟⇩∘ r ∈⇩∘ Vset α"
and "ℛ⇩∘ r ⊆⇩∘ Vset α"
and "vfinite (𝒟⇩∘ r)"
shows "r ∈⇩∘ Vset α"
by (simp add: assms vsv_Limit_vrange_in_VsetI vbrelation_Limit_in_VsetI)
lemma Limit_vcomp_in_VsetI:
assumes "Limit α" and "r ∈⇩∘ Vset α" and "s ∈⇩∘ Vset α"
shows "r ∘⇩∘ s ∈⇩∘ Vset α"
proof(rule vbrelation.vbrelation_Limit_in_VsetI; (intro assms(1))?)
show "vbrelation (r ∘⇩∘ s)" by auto
have "𝒟⇩∘ (r ∘⇩∘ s) ⊆⇩∘ 𝒟⇩∘ s" by auto
with assms(3) show "𝒟⇩∘ (r ∘⇩∘ s) ∈⇩∘ Vset α"
by (auto simp: vdomain_in_VsetI vsubset_in_VsetI)
have "ℛ⇩∘ (r ∘⇩∘ s) ⊆⇩∘ ℛ⇩∘ r" by auto
with assms(2) show "ℛ⇩∘ (r ∘⇩∘ s) ∈⇩∘ Vset α"
by (auto simp: vrange_in_VsetI vsubset_in_VsetI)
qed
text‹Operations on indexed families of sets.›
lemma Limit_vifintersection_in_VsetI:
assumes "Limit α" and "⋀i. i ∈⇩∘ I ⟹ A i ∈⇩∘ Vset α" and "vfinite I"
shows "(⋂⇩∘i∈⇩∘I. A i) ∈⇩∘ Vset α"
proof-
from assms(2) have range: "ℛ⇩∘ (λi∈⇩∘I. A i) ⊆⇩∘ Vset α" by auto
from assms(1) range assms(3) have "ℛ⇩∘ (λi∈⇩∘I. A i) ∈⇩∘ Vset α"
by (rule rel_VLambda.vsv_Limit_vrange_in_VsetI[unfolded vdomain_VLambda])
then have "(λi∈⇩∘I. A i) `⇩∘ I ∈⇩∘ Vset α"
by (simp add: vimage_VLambda_vrange_rep)
then show "(⋂⇩∘i∈⇩∘I. A i) ∈⇩∘ Vset α" by auto
qed
lemma Limit_vifunion_in_VsetI:
assumes "Limit α" and "⋀i. i ∈⇩∘ I ⟹ A i ∈⇩∘ Vset α" and "vfinite I"
shows "(⋃⇩∘i∈⇩∘I. A i) ∈⇩∘ Vset α"
proof-
from assms(2) have range: "ℛ⇩∘ (λi∈⇩∘I. A i) ⊆⇩∘ Vset α" by auto
from assms(1) range assms(3) have "ℛ⇩∘ (λi∈⇩∘I. A i) ∈⇩∘ Vset α"
by (rule rel_VLambda.vsv_Limit_vrange_in_VsetI[unfolded vdomain_VLambda])
then have "(λi∈⇩∘I. A i) `⇩∘ I ∈⇩∘ Vset α"
by (simp add: vimage_VLambda_vrange_rep)
then show "(⋃⇩∘i∈⇩∘I. A i) ∈⇩∘ Vset α" by auto
qed
lemma Limit_vifunion_in_Vset_if_VLambda_in_VsetI:
assumes "Limit α" and "VLambda I A ∈⇩∘ Vset α"
shows "(⋃⇩∘i∈⇩∘I. A i) ∈⇩∘ Vset α"
proof-
from assms(2) have "ℛ⇩∘ (λi∈⇩∘I. A i) ∈⇩∘ Vset α"
by (simp add: vrange_in_VsetI)
then have "(λi∈⇩∘I. A i) `⇩∘ I ∈⇩∘ Vset α"
by (simp add: vimage_VLambda_vrange_rep)
then show "(⋃⇩∘i∈⇩∘I. A i) ∈⇩∘ Vset α" by auto
qed
lemma Limit_vproduct_in_VsetI:
assumes "Limit α"
and "I ∈⇩∘ Vset α"
and "⋀i. i ∈⇩∘ I ⟹ A i ∈⇩∘ Vset α"
and "vfinite I"
shows "(∏⇩∘i∈⇩∘I. A i) ∈⇩∘ Vset α"
proof-
have "(⋃⇩∘i∈⇩∘I. A i) ∈⇩∘ Vset α"
by (rule Limit_vifunion_in_VsetI) (simp_all add: assms(1,3,4))
with assms have "I ×⇩∘ (⋃⇩∘i∈⇩∘I. A i) ∈⇩∘ Vset α" by auto
with assms(1) have "VPow (I ×⇩∘ (⋃⇩∘i∈⇩∘I. A i)) ∈⇩∘ Vset α" by auto
from vsubset_in_VsetI[OF vproduct_vsubset_VPow[of I A] this] show ?thesis
by simp
qed
lemma Limit_vproduct_in_Vset_if_VLambda_in_VsetI:
assumes "Limit α" and "VLambda I A ∈⇩∘ Vset α"
shows "(∏⇩∘i∈⇩∘I. A i) ∈⇩∘ Vset α"
proof-
have "(⋃⇩∘i∈⇩∘I. A i) ∈⇩∘ Vset α"
by (rule Limit_vifunion_in_Vset_if_VLambda_in_VsetI)
(simp_all add: assms)
moreover from assms(2) have "I ∈⇩∘ Vset α"
by (metis vdomain_VLambda vdomain_in_VsetI)
ultimately have "I ×⇩∘ (⋃⇩∘i∈⇩∘I. A i) ∈⇩∘ Vset α"
using assms by auto
with assms(1) have "VPow (I ×⇩∘ (⋃⇩∘i∈⇩∘I. A i)) ∈⇩∘ Vset α" by auto
from vsubset_in_VsetI[OF vproduct_vsubset_VPow[of I A] this] show ?thesis
by simp
qed
lemma vrange_vprojection_in_VsetI:
assumes "Limit α"
and "A ∈⇩∘ Vset α"
and "⋀f. f ∈⇩∘ A ⟹ vsv f"
and "⋀f. f ∈⇩∘ A ⟹ x ∈⇩∘ 𝒟⇩∘ f"
shows "ℛ⇩∘ (λf∈⇩∘A. f⦇x⦈) ∈⇩∘ Vset α"
proof-
have "ℛ⇩∘ (λf∈⇩∘A. f⦇x⦈) ⊆⇩∘ ⋃⇩∘(⋃⇩∘(⋃⇩∘A))"
proof(intro vsubsetI)
fix y assume "y ∈⇩∘ ℛ⇩∘ (λf∈⇩∘A. f⦇x⦈)"
then obtain f where f: "f ∈⇩∘ A" and y_def: "y = f⦇x⦈" by auto
from f have "vsv f" and "x ∈⇩∘ 𝒟⇩∘ f" by (auto intro: assms(3,4))+
with y_def have xy: "⟨x, y⟩ ∈⇩∘ f" by auto
show "y ∈⇩∘ ⋃⇩∘(⋃⇩∘(⋃⇩∘A))"
proof(intro VUnionI)
show "f ∈⇩∘ A" by (rule f)
show "⟨x, y⟩ ∈⇩∘ f" by (rule xy)
show "set {x, y} ∈⇩∘ ⟨x, y⟩" unfolding vpair_def by simp
qed auto
qed
moreover from assms(1,2) have "⋃⇩∘(⋃⇩∘(⋃⇩∘A)) ∈⇩∘ Vset α"
by (intro VUnion_in_VsetI)
ultimately show ?thesis by auto
qed
lemma Limit_vcpower_in_VsetI:
assumes "Limit α" and "n ∈⇩∘ Vset α" and "A ∈⇩∘ Vset α" and "vfinite n"
shows "A ^⇩× n ∈⇩∘ Vset α"
using assms Limit_vproduct_in_VsetI unfolding vcpower_def by auto
text‹Finite sets.›
lemma Limit_vfinite_in_VsetI:
assumes "Limit α" and "A ⊆⇩∘ Vset α" and "vfinite A"
shows "A ∈⇩∘ Vset α"
proof-
from assms(3) obtain n where n: "n ∈⇩∘ ω" and "n ≈⇩∘ A" by clarsimp
then obtain f where f: "v11 f" and dr: "𝒟⇩∘ f = n" "ℛ⇩∘ f = A" by auto
interpret f: v11 f by (rule f)
from n have n: "vfinite n" by auto
show ?thesis
by (rule f.vsv_Limit_vrange_in_VsetI[simplified dr, OF assms(1,2) n])
qed
text‹Ordinal numbers.›
lemma Limit_omega_in_VsetI:
assumes "Limit α"
shows "a⇩ℕ ∈⇩∘ Vset α"
proof-
from assms have "α ⊆⇩∘ Vset α" by force
moreover have "ω ⊆⇩∘ α" by (simp add: assms omega_le_Limit)
moreover have "a⇩ℕ ∈⇩∘ ω" by simp
ultimately show "a⇩ℕ ∈⇩∘ Vset α" by auto
qed
lemma Limit_succ_in_VsetI:
assumes "Limit α" and "a ∈⇩∘ Vset α"
shows "succ a ∈⇩∘ Vset α"
by (simp add: assms succ_def vinsert_in_VsetI)
text‹Sequences.›
lemma (in vfsequence) vfsequence_Limit_vcons_in_VsetI:
assumes "Limit α" and "x ∈⇩∘ Vset α" and "xs ∈⇩∘ Vset α"
shows "vcons xs x ∈⇩∘ Vset α"
unfolding vcons_def
proof(intro vinsert_in_VsetI Limit_vpair_in_VsetI assms)
show "vcard xs ∈⇩∘ Vset α"
by (metis assms(3) vdomain_in_VsetI vfsequence_vdomain)
qed
text‹‹ftimes›.›
lemma Limit_ftimes_in_VsetI:
assumes "Limit α" and "A ∈⇩∘ Vset α" and "B ∈⇩∘ Vset α"
shows "A ×⇩∙ B ∈⇩∘ Vset α"
unfolding ftimes_def
proof(rule Limit_vproduct_in_VsetI)
from assms(1) show "2⇩ℕ ∈⇩∘ Vset α" by (meson Limit_omega_in_VsetI)
fix i assume "i ∈⇩∘ 2⇩ℕ"
with assms(2,3) show "(i = 0 ? A : B) ∈⇩∘ Vset α" by simp
qed (auto simp: assms(1))
text‹Auxiliary results.›
lemma vempty_in_Vset_succ[simp, intro]: "0 ∈⇩∘ Vfrom a (succ b)"
unfolding Vfrom_succ by force
lemma Ord_vpair_in_Vset_succI[intro]:
assumes "Ord α" and "a ∈⇩∘ Vset α" and "b ∈⇩∘ Vset α"
shows "⟨a, b⟩ ∈⇩∘ Vset (succ (succ α))"
unfolding vpair_def
proof-
have aab: "set {set {a}, set {a, b}} = vinsert (set {a}) (set {set {a, b}})"
by auto
show "set {set {a}, set {a, b}} ∈⇩∘ Vset (succ (succ α))"
unfolding aab
by
(
intro
assms
vinsert_in_Vset_succI'
Ord_vsingleton_in_Vset_succI
Ord_vdoubleton_in_Vset_succI
Ord_succ
)
qed
lemma Limit_vifunion_vsubset_VsetI:
assumes "Limit α" and "⋀i. i ∈⇩∘ I ⟹ A i ∈⇩∘ Vset α"
shows "(⋃⇩∘i∈⇩∘I. A i) ⊆⇩∘ Vset α"
proof(intro vsubsetI)
fix x assume "x ∈⇩∘ (⋃⇩∘i∈⇩∘I. A i)"
then obtain i where i: "i ∈⇩∘ I" and "x ∈⇩∘ A i" by auto
with assms(1) assms(2)[OF i] show "x ∈⇩∘ Vset α" by auto
qed
lemma Limit_vproduct_vsubset_Vset_succI:
assumes "Limit α" and "I ∈⇩∘ Vset α" and "⋀i. i ∈⇩∘ I ⟹ A i ⊆⇩∘ Vset α"
shows "(∏⇩∘i∈⇩∘I. A i) ⊆⇩∘ Vset (succ α)"
proof(intro vsubsetI)
fix a assume prems: "a ∈⇩∘ (∏⇩∘i∈⇩∘I. A i)"
note a = vproductD[OF prems]
interpret vsv a by (rule a(1))
from prems have "ℛ⇩∘ a ⊆⇩∘ (⋃⇩∘i∈⇩∘I. A i)" by (rule vproduct_vrange)
moreover have "(⋃⇩∘i∈⇩∘I. A i) ⊆⇩∘ Vset α" by (intro vifunion_least assms(3))
ultimately have "ℛ⇩∘ a ⊆⇩∘ Vset α" by auto
moreover from assms(2) prems have "𝒟⇩∘ a ⊆⇩∘ Vset α" unfolding a(2) by auto
ultimately have "a ⊆⇩∘ Vset α"
by (intro assms(1) vbrelation_Limit_vsubset_VsetI)
with assms(1) show "a ∈⇩∘ Vset (succ α)"
by (simp add: Limit_is_Ord Ord_vsubset_in_Vset_succI)
qed
lemma Limit_vproduct_vsubset_Vset_succI':
assumes "Limit α" and "I ∈⇩∘ Vset α" and "⋀i. i ∈⇩∘ I ⟹ A i ∈⇩∘ Vset α"
shows "(∏⇩∘i∈⇩∘I. A i) ⊆⇩∘ Vset (succ α)"
proof-
have "A i ⊆⇩∘ Vset α" if "i ∈⇩∘ I" for i
by (simp add: Vset_trans vsubsetI assms(3) that)
from assms(1,2) this show ?thesis by (rule Limit_vproduct_vsubset_Vset_succI)
qed
lemma (in vfsequence) vfsequence_Ord_vcons_in_Vset_succI:
assumes "Ord α"
and "ω ∈⇩∘ α"
and "x ∈⇩∘ Vset α"
and "xs ∈⇩∘ Vset (succ (succ (succ α)))"
shows "vcons xs x ∈⇩∘ Vset (succ (succ (succ α)))"
unfolding vcons_def
proof(intro vinsert_in_Vset_succI' Ord_succ Ord_vpair_in_Vset_succI assms)
have "vcard xs = 𝒟⇩∘ xs" by (simp add: vfsequence_vdomain)
from assms(1,2) vfsequence_vdomain_in_omega show "vcard xs ∈⇩∘ Vset α"
unfolding vfsequence_vdomain[symmetric]
by (meson Ord_in_in_VsetI Vset_trans)
qed
lemma Limit_VUnion_vdomain_in_VsetI:
assumes "Limit α" and "Q ∈⇩∘ Vset α"
shows "(⋃⇩∘r∈⇩∘Q. 𝒟⇩∘ r) ∈⇩∘ Vset α"
proof-
have "(⋃⇩∘r∈⇩∘Q. 𝒟⇩∘ r) ⊆⇩∘ ⋃⇩∘(⋃⇩∘(⋃⇩∘Q))"
proof(intro vsubsetI)
fix a assume "a ∈⇩∘ (⋃⇩∘r∈⇩∘Q. 𝒟⇩∘ r)"
then obtain r where r: "r ∈⇩∘ Q" and "a ∈⇩∘ 𝒟⇩∘ r" by auto
with assms obtain b where ab: "⟨a, b⟩ ∈⇩∘ r" by auto
show "a ∈⇩∘ ⋃⇩∘(⋃⇩∘(⋃⇩∘Q))"
proof(intro VUnionI)
show "r ∈⇩∘ Q" by (rule r)
show "⟨a, b⟩ ∈⇩∘ r" by (rule ab)
show "set {a, b} ∈⇩∘ ⟨a, b⟩" unfolding vpair_def by simp
qed auto
qed
moreover from assms(2) have "⋃⇩∘(⋃⇩∘(⋃⇩∘Q)) ∈⇩∘ Vset α"
by (blast dest!: VUnion_in_VsetI)
ultimately show ?thesis using assms(1) by (auto simp: vsubset_in_VsetI)
qed
lemma Limit_VUnion_vrange_in_VsetI:
assumes "Limit α" and "Q ∈⇩∘ Vset α"
shows "(⋃⇩∘r∈⇩∘Q. ℛ⇩∘ r) ∈⇩∘ Vset α"
proof-
have "(⋃⇩∘r∈⇩∘Q. ℛ⇩∘ r) ⊆⇩∘ ⋃⇩∘(⋃⇩∘(⋃⇩∘Q))"
proof(intro vsubsetI)
fix b assume "b ∈⇩∘ (⋃⇩∘r∈⇩∘Q. ℛ⇩∘ r)"
then obtain r where r: "r ∈⇩∘ Q" and "b ∈⇩∘ ℛ⇩∘ r" by auto
with assms obtain a where ab: "⟨a, b⟩ ∈⇩∘ r" by auto
show "b ∈⇩∘ ⋃⇩∘(⋃⇩∘(⋃⇩∘Q))"
proof(intro VUnionI)
show "r ∈⇩∘ Q" by (rule r)
show "⟨a, b⟩ ∈⇩∘ r" by (rule ab)
show "set {a, b} ∈⇩∘ ⟨a, b⟩" unfolding vpair_def by simp
qed auto
qed
moreover from assms(2) have "⋃⇩∘(⋃⇩∘(⋃⇩∘Q)) ∈⇩∘ Vset α"
by (blast dest!: VUnion_in_VsetI)
ultimately show ?thesis using assms(1) by (auto simp: vsubset_in_VsetI)
qed
subsection‹Axioms for \<^term>‹Vset α››
text‹
The subsection demonstrates that the axioms of ZFC except for the
Axiom Schema of Replacement hold in \<^term>‹Vset α› for any limit ordinal
\<^term>‹α› such that \<^term>‹ω ∈⇩∘ α›\footnote{The presentation of the axioms is
loosely based on the statement of the axioms of ZFC in Chapters 1-11 in
\cite{takeuti_introduction_1971}.}.
›
locale 𝒵 =
fixes α
assumes Limit_α[intro, simp]: "Limit α"
and omega_in_α[intro, simp]: "ω ∈⇩∘ α"
begin
lemmas [intro] = 𝒵_axioms
lemma vempty_Z_def: "0 = set {x. x ≠ x}" by auto
lemma vempty_is_zet[intro, simp]: "0 ∈⇩∘ Vset α"
using Vset_in_mono omega_in_α by auto
lemma Axiom_of_Extensionality:
assumes "a ∈⇩∘ Vset α" and "x = y" and "x ∈⇩∘ a"
shows "y ∈⇩∘ a" and "x ∈⇩∘ Vset α" and "y ∈⇩∘ Vset α"
using assms by (simp_all add: Vset_trans)
lemma Axiom_of_Pairing:
assumes "a ∈⇩∘ Vset α" and "b ∈⇩∘ Vset α"
shows "set {a, b} ∈⇩∘ Vset α"
using assms by (simp add: Limit_vdoubleton_in_VsetI)
lemma Axiom_of_Unions:
assumes "a ∈⇩∘ Vset α"
shows "⋃⇩∘a ∈⇩∘ Vset α"
using assms by (simp add: VUnion_in_VsetI)
lemma Axiom_of_Powers:
assumes "a ∈⇩∘ Vset α"
shows "VPow a ∈⇩∘ Vset α"
using assms by (simp add: Limit_VPow_in_VsetI)
lemma Axiom_of_Regularity:
assumes "a ≠ 0" and "a ∈⇩∘ Vset α"
obtains x where "x ∈⇩∘ a" and "x ∩⇩∘ a = 0"
using assms by (auto dest: trad_foundation)
lemma Axiom_of_Infinity: "ω ∈⇩∘ Vset α"
using Limit_is_Ord by (auto simp: Ord_iff_rank Ord_VsetI OrdmemD)
lemma Axiom_of_Choice:
assumes "A ∈⇩∘ Vset α"
obtains f where "f ∈⇩∘ Vset α" and "⋀x. x ∈⇩∘ A ⟹ x ≠ 0 ⟹ f⦇x⦈ ∈⇩∘ x"
proof-
define f where "f = (λx∈⇩∘A. (SOME a. a ∈⇩∘ x ∨ (x = 0 ∧ a = 0)))"
interpret vsv f unfolding f_def by auto
have A_def: "A = 𝒟⇩∘ f" unfolding f_def by simp
have Rf: "ℛ⇩∘ f ⊆⇩∘ vinsert 0 (⋃⇩∘A)"
proof(rule vsubsetI)
fix y assume "y ∈⇩∘ ℛ⇩∘ f"
then obtain x where "x ∈⇩∘ A" and "y = f⦇x⦈"
unfolding A_def by (blast dest: vrange_atD)
then have y_def: "y = (SOME a. a ∈⇩∘ x ∨ x = 0 ∧ a = 0)"
unfolding f_def unfolding A_def by simp
have "y = 0 ∨ y ∈⇩∘ x"
proof(cases ‹x = 0›)
case False then show ?thesis
unfolding y_def by (metis (mono_tags, lifting) verit_sko_ex' vemptyE)
qed (simp add: y_def)
with ‹x ∈⇩∘ A› show "y ∈⇩∘ vinsert 0 (⋃⇩∘A)" by clarsimp
qed
from assms have "⋃⇩∘A ∈⇩∘ Vset α" by (simp add: Axiom_of_Unions)
with vempty_is_zet Limit_α have "vinsert 0 (⋃⇩∘A) ∈⇩∘ Vset α" by auto
with Rf have "ℛ⇩∘ f ∈⇩∘ Vset α" by auto
with Limit_α assms[unfolded A_def] have "f ∈⇩∘ Vset α" by auto
moreover have "x ∈⇩∘ A ⟹ x ≠ 0 ⟹ f⦇x⦈ ∈⇩∘ x" for x
proof-
assume prems: "x ∈⇩∘ A" "x ≠ 0"
then have "f⦇x⦈ = (SOME a. a ∈⇩∘ x ∨ (x = 0 ∧ a = 0))"
unfolding f_def by simp
with prems(2) show "f⦇x⦈ ∈⇩∘ x"
by (metis (mono_tags, lifting) someI_ex vemptyE)
qed
ultimately show ?thesis by (simp add: that)
qed
end
text‹Trivial corollaries.›
lemma (in 𝒵) Ord_α: "Ord α" by auto
lemma (in 𝒵) 𝒵_Vset_ω2_vsubset_Vset: "Vset (ω + ω) ⊆⇩∘ Vset α"
by (simp add: Vset_vsubset_mono omega2_vsubset_Limit)
lemma (in 𝒵) 𝒵_Limit_αω: "Limit (α + ω)" by (simp add: Limit_is_Ord)
lemma (in 𝒵) 𝒵_α_αω: "α ∈⇩∘ α + ω"
by (simp add: Limit_is_Ord Ord_mem_iff_lt)
lemma (in 𝒵) 𝒵_ω_αω: "ω ∈⇩∘ α + ω"
using add_le_cancel_left0 by blast
lemma 𝒵_ωω: "𝒵 (ω + ω)"
using ω_gt0 by (auto intro: 𝒵.intro simp: Ord_mem_iff_lt)
lemma (in 𝒵) in_omega_in_omega_plus[intro]:
assumes "a ∈⇩∘ ω"
shows "a ∈⇩∘ Vset (α + ω)"
proof-
from assms have "a ∈⇩∘ Vset ω" by auto
moreover have "Vset ω ∈⇩∘ Vset (α + ω)" by (simp add: Vset_in_mono 𝒵_ω_αω)
ultimately show "a ∈⇩∘ Vset (α + ω)" by auto
qed
lemma (in 𝒵) ord_of_nat_in_Vset[simp]: "a⇩ℕ ∈⇩∘ Vset α" by force
subsection‹Existence of a disjoint subset in \<^term>‹Vset α››
definition mk_doubleton :: "V ⇒ V ⇒ V"
where "mk_doubleton X a = set {a, X}"
definition mk_doubleton_image :: "V ⇒ V ⇒ V"
where "mk_doubleton_image X Y = set (mk_doubleton Y ` elts X)"
lemma inj_on_mk_doubleton: "inj_on (mk_doubleton X) (elts X)"
proof
fix a b assume "mk_doubleton X a = mk_doubleton X b"
then have "{a, X} = {b, X}" unfolding mk_doubleton_def by auto
then show "a = b" by (metis doubleton_eq_iff)
qed
lemma mk_doubleton_image_vsubset_veqpoll:
assumes "X ⊆⇩∘ Y"
shows "mk_doubleton_image X X ≈⇩∘ mk_doubleton_image X Y"
unfolding eqpoll_def
proof(intro exI[of _ ‹λA. vinsert Y (A -⇩∘ set {X})›] bij_betw_imageI)
show "inj_on (λA. vinsert Y (A -⇩∘ set {X})) (elts (mk_doubleton_image X X))"
unfolding mk_doubleton_image_def
proof(intro inj_onI)
fix y y' assume prems:
"y ∈⇩∘ set (mk_doubleton X ` elts X)"
"y' ∈⇩∘ set (mk_doubleton X ` elts X)"
"vinsert Y (y -⇩∘ set {X}) = vinsert Y (y' -⇩∘ set {X})"
then obtain x x'
where "x ∈⇩∘ X"
and "x' ∈⇩∘ X"
and y_def: "y = set {x, X}"
and y'_def: "y' = set {x', X}"
by (clarsimp simp: mk_doubleton_def)
with assms have xX_X: "set {x, X} -⇩∘ set {X} = set {x}"
and x'X_X: "set {x', X} -⇩∘ set {X} = set {x'}"
by fastforce+
from prems(3)[unfolded y_def y'_def] have "set {x, Y} = set {x', Y}"
unfolding xX_X x'X_X by auto
then have "x = x'" by (auto simp: doubleton_eq_iff)
then show "y = y'" unfolding y_def y'_def by simp
qed
show
"(λA. vinsert Y (A -⇩∘ set {X})) ` (elts (mk_doubleton_image X X)) =
(elts (mk_doubleton_image X Y))"
proof(intro subset_antisym subsetI)
fix z
assume prems:
"z ∈ (λA. vinsert Y (A -⇩∘ set {X})) ` (elts (mk_doubleton_image X X))"
then obtain y
where "y ∈⇩∘ set (mk_doubleton X ` elts X)"
and z_def: "z = vinsert Y (y -⇩∘ set {X})"
unfolding mk_doubleton_image_def by auto
then obtain x where xX: "x ∈⇩∘ X" and y_def: "y = set {x, X}"
unfolding mk_doubleton_def by clarsimp
from xX have y_X: "y -⇩∘ set {X} = set {x}" unfolding y_def by fastforce
from z_def have z_def': "z = set {x, Y}"
unfolding y_X by (simp add: doubleton_eq_iff vinsert_vsingleton)
from xX show "z ∈⇩∘ mk_doubleton_image X Y"
unfolding z_def' mk_doubleton_def mk_doubleton_image_def by simp
next
fix z assume prems: "z ∈⇩∘ mk_doubleton_image X Y"
then obtain x where xX: "x ∈⇩∘ X" and z_def: "z = set {x, Y}"
unfolding mk_doubleton_def mk_doubleton_image_def by clarsimp
from xX have xX_XX: "set {x, X} ∈⇩∘ set (mk_doubleton X ` elts X)"
unfolding mk_doubleton_def by simp
from xX have xX_X: "set {x, X} -⇩∘ set {X} = set {x}" by fastforce
have z_def': "z = vinsert Y (set {x, X} -⇩∘ set {X})"
unfolding xX_X z_def by auto
with xX_XX show
"z ∈ (λA. vinsert Y (A -⇩∘ set {X})) ` (elts (mk_doubleton_image X X))"
unfolding z_def' mk_doubleton_image_def by simp
qed
qed
lemma mk_doubleton_image_veqpoll:
assumes "X ⊆⇩∘ Y"
shows "X ≈⇩∘ mk_doubleton_image X Y"
proof-
have "X ≈⇩∘ mk_doubleton_image X X"
unfolding mk_doubleton_image_def by (auto simp: inj_on_mk_doubleton)
also have "… ≈ elts (mk_doubleton_image X Y)"
by (rule mk_doubleton_image_vsubset_veqpoll[OF assms])
finally show "X ≈⇩∘ mk_doubleton_image X Y".
qed
lemma vdisjnt_mk_doubleton_image: "vdisjnt (mk_doubleton_image X Y) Y"
proof
fix b assume prems: "b ∈⇩∘ Y" "b ∈⇩∘ mk_doubleton_image X Y"
then obtain a where "a ∈⇩∘ X" and "set {a, Y} = b"
unfolding mk_doubleton_def mk_doubleton_image_def by clarsimp
then have "Y ∈⇩∘ b" by clarsimp
with mem_not_sym show False by (simp add: prems)
qed
lemma Limit_mk_doubleton_image_vsubset_Vset:
assumes "Limit α" and "X ⊆⇩∘ Y" and "Y ∈⇩∘ Vset α"
shows "mk_doubleton_image X Y ⊆⇩∘ Vset α"
proof(intro vsubsetI)
fix b assume "b ∈⇩∘ mk_doubleton_image X Y"
then obtain a where "b = mk_doubleton Y a" and "a ∈⇩∘ X"
unfolding mk_doubleton_image_def by clarsimp
with assms have b_def: "b = set {a, Y}" and aα: "a ∈⇩∘ Vset α"
by (auto simp: mk_doubleton_def)
from this(2) assms show "b ∈⇩∘ Vset α"
unfolding b_def by (simp add: Limit_vdoubleton_in_VsetI)
qed
lemma Ord_mk_doubleton_image_vsubset_Vset_succ:
assumes "Ord α" and "X ⊆⇩∘ Y" and "Y ∈⇩∘ Vset α"
shows "mk_doubleton_image X Y ⊆⇩∘ Vset (succ α)"
proof(intro vsubsetI)
fix b assume "b ∈⇩∘ mk_doubleton_image X Y"
then obtain a where "b = mk_doubleton Y a" and "a ∈⇩∘ X"
unfolding mk_doubleton_image_def by clarsimp
with assms have b_def: "b = set {a, Y}" and aα: "a ∈⇩∘ Vset α"
by (auto simp: mk_doubleton_def)
from this(2) assms show "b ∈⇩∘ Vset (succ α)"
unfolding b_def by (simp add: Ord_vdoubleton_in_Vset_succI)
qed
lemma Limit_ex_eqpoll_vdisjnt:
assumes "Limit α" and "X ⊆⇩∘ Y" and "Y ∈⇩∘ Vset α"
obtains Z where "X ≈⇩∘ Z" and "vdisjnt Z Y" and "Z ⊆⇩∘ Vset α"
using assms
by (intro that[of ‹mk_doubleton_image X Y›])
(
simp_all add:
mk_doubleton_image_veqpoll
vdisjnt_mk_doubleton_image
Limit_mk_doubleton_image_vsubset_Vset
)
lemma Ord_ex_eqpoll_vdisjnt:
assumes "Ord α" and "X ⊆⇩∘ Y" and "Y ∈⇩∘ Vset α"
obtains Z where "X ≈⇩∘ Z" and "vdisjnt Z Y" and "Z ⊆⇩∘ Vset (succ α)"
using assms
by (intro that[of ‹mk_doubleton_image X Y›])
(
simp_all add:
mk_doubleton_image_veqpoll
vdisjnt_mk_doubleton_image
Ord_mk_doubleton_image_vsubset_Vset_succ
)
text‹\newpage›
end
Theory CZH_Sets_NOP
section‹‹n›-ary operation›
theory CZH_Sets_NOP
imports CZH_Sets_FBRelations
begin
subsection‹Partial ‹n›-ary operation›
locale pnop = vsv f for A n f :: V +
assumes pnop_n: "n ∈⇩∘ ω"
and pnop_vdomain: "𝒟⇩∘ f ⊆⇩∘ A ^⇩× n"
and pnop_vrange: "ℛ⇩∘ f ⊆⇩∘ A"
text‹Rules.›
lemma pnopI[intro]:
assumes "vsv f"
and "n ∈⇩∘ ω"
and "𝒟⇩∘ f ⊆⇩∘ A ^⇩× n"
and "ℛ⇩∘ f ⊆⇩∘ A"
shows "pnop A n f"
using assms unfolding pnop_def pnop_axioms_def by blast
lemma pnopD[dest]:
assumes "pnop A n f"
shows "vsv f"
and "n ∈⇩∘ ω"
and "𝒟⇩∘ f ⊆⇩∘ A ^⇩× n"
and "ℛ⇩∘ f ⊆⇩∘ A"
using assms unfolding pnop_def pnop_axioms_def by blast+
lemma pnopE[elim]:
assumes "pnop A n f"
obtains "vsv f"
and "n ∈⇩∘ ω"
and "𝒟⇩∘ f ⊆⇩∘ A ^⇩× n"
and "ℛ⇩∘ f ⊆⇩∘ A"
using assms by force
subsection‹Total ‹n›-ary operation›
locale nop = vsv f for A n f :: V +
assumes nop_n: "n ∈⇩∘ ω"
and nop_vdomain: "𝒟⇩∘ f = A ^⇩× n"
and nop_vrange: "ℛ⇩∘ f ⊆⇩∘ A"
sublocale nop ⊆ pnop A n f
proof(intro pnopI)
show "vsv f" by (rule vsv_axioms)
show "n ∈⇩∘ ω" by (rule nop_n)
from nop_vdomain show "𝒟⇩∘ f ⊆⇩∘ A ^⇩× n" by simp
show "ℛ⇩∘ f ⊆⇩∘ A" by (rule nop_vrange)
qed
text‹Rules.›
lemma nopI[intro]:
assumes "vsv f"
and "n ∈⇩∘ ω"
and "𝒟⇩∘ f = A ^⇩× n"
and "ℛ⇩∘ f ⊆⇩∘ A"
shows "nop A n f"
using assms unfolding nop_def nop_axioms_def by blast
lemma nopD[dest]:
assumes "nop A n f"
shows "vsv f"
and "n ∈⇩∘ ω"
and "𝒟⇩∘ f = A ^⇩× n"
and "ℛ⇩∘ f ⊆⇩∘ A"
using assms unfolding nop_def nop_axioms_def by blast+
lemma nopE[elim]:
assumes "nop A n f"
obtains "vsv f"
and "n ∈⇩∘ ω"
and "𝒟⇩∘ f = A ^⇩× n"
and "ℛ⇩∘ f ⊆⇩∘ A"
using assms by force
subsection‹Injective ‹n›-ary operation›
locale nop_v11 = v11 f for A n f :: V +
assumes nop_v11_n: "n ∈⇩∘ ω"
and nop_v11_vdomain: "𝒟⇩∘ f = A ^⇩× n"
and nop_v11_vrange: "ℛ⇩∘ f ⊆⇩∘ A"
sublocale nop_v11 ⊆ nop
proof
show "vsv f" by (rule vsv_axioms)
show "n ∈⇩∘ ω" by (rule nop_v11_n)
show "𝒟⇩∘ f = A ^⇩× n" by (rule nop_v11_vdomain)
show "ℛ⇩∘ f ⊆⇩∘ A" by (rule nop_v11_vrange)
qed
text‹Rules.›
lemma nop_v11I[intro]:
assumes "v11 f"
and "n ∈⇩∘ ω"
and "𝒟⇩∘ f = A ^⇩× n"
and "ℛ⇩∘ f ⊆⇩∘ A"
shows "nop_v11 A n f"
using assms unfolding nop_v11_def nop_v11_axioms_def by blast
lemma nop_v11D[dest]:
assumes "nop_v11 A n f"
shows "v11 f"
and "n ∈⇩∘ ω"
and "𝒟⇩∘ f = A ^⇩× n"
and "ℛ⇩∘ f ⊆⇩∘ A"
using assms unfolding nop_v11_def nop_v11_axioms_def by blast+
lemma nop_v11E[elim]:
assumes "nop_v11 A n f"
obtains "v11 f"
and "n ∈⇩∘ ω"
and "𝒟⇩∘ f = A ^⇩× n"
and "ℛ⇩∘ f ⊆⇩∘ A"
using assms by force
subsection‹Surjective ‹n›-ary operation›
locale nop_onto = vsv f for A n f :: V +
assumes nop_onto_n: "n ∈⇩∘ ω"
and nop_onto_vdomain: "𝒟⇩∘ f = A ^⇩× n"
and nop_onto_vrange: "ℛ⇩∘ f = A"
sublocale nop_onto ⊆ nop
proof
show "vsv f" by (rule vsv_axioms)
show "n ∈⇩∘ ω" by (rule nop_onto_n)
show "𝒟⇩∘ f = A ^⇩× n" by (rule nop_onto_vdomain)
show "ℛ⇩∘ f ⊆⇩∘ A" by (simp add: nop_onto_vrange)
qed
text‹Rules.›
lemma nop_ontoI[intro]:
assumes "vsv f"
and "n ∈⇩∘ ω"
and "𝒟⇩∘ f = A ^⇩× n"
and "ℛ⇩∘ f = A"
shows "nop_onto A n f"
using assms unfolding nop_onto_def nop_onto_axioms_def by blast
lemma nop_ontoD[dest]:
assumes "nop_onto A n f"
shows "vsv f"
and "n ∈⇩∘ ω"
and "𝒟⇩∘ f = A ^⇩× n"
and "ℛ⇩∘ f = A"
using assms unfolding nop_onto_def nop_onto_axioms_def by auto
lemma nop_ontoE[elim]:
assumes "nop_onto A n f"
obtains "vsv f"
and "n ∈⇩∘ ω"
and "𝒟⇩∘ f = A ^⇩× n"
and "ℛ⇩∘ f = A"
using assms by force
subsection‹Bijective ‹n›-ary operation›
locale nop_bij = v11 f for A n f :: V +
assumes nop_bij_n: "n ∈⇩∘ ω"
and nop_bij_vdomain: "𝒟⇩∘ f = A ^⇩× n"
and nop_bij_vrange: "ℛ⇩∘ f = A"
sublocale nop_bij ⊆ nop_v11
proof
show "v11 f" by (rule v11_axioms)
show "n ∈⇩∘ ω" by (rule nop_bij_n)
show "𝒟⇩∘ f = A ^⇩× n" by (rule nop_bij_vdomain)
show "ℛ⇩∘ f ⊆⇩∘ A" by (simp add: nop_bij_vrange)
qed
sublocale nop_bij ⊆ nop_onto
proof
show "vsv f" by (rule vsv_axioms)
show "n ∈⇩∘ ω" by (rule nop_bij_n)
show "𝒟⇩∘ f = A ^⇩× n" by (rule nop_bij_vdomain)
show "ℛ⇩∘ f = A" by (rule nop_bij_vrange)
qed
text‹Rules.›
lemma nop_bijI[intro]:
assumes "v11 f"
and "n ∈⇩∘ ω"
and "𝒟⇩∘ f = A ^⇩× n"
and "ℛ⇩∘ f = A"
shows "nop_bij A n f"
using assms unfolding nop_bij_def nop_bij_axioms_def by blast
lemma nop_bijD[dest]:
assumes "nop_bij A n f"
shows "v11 f"
and "n ∈⇩∘ ω"
and "𝒟⇩∘ f = A ^⇩× n"
and "ℛ⇩∘ f = A"
using assms unfolding nop_bij_def nop_bij_axioms_def by auto
lemma nop_bijE[elim]:
assumes "nop_bij A n f"
obtains "v11 f"
and "n ∈⇩∘ ω"
and "𝒟⇩∘ f = A ^⇩× n"
and "ℛ⇩∘ f = A"
using assms by force
subsection‹Scalar›
locale scalar =
fixes A f
assumes scalar_nop: "nop A 0 f"
sublocale scalar ⊆ nop A 0 f
rewrites scalar_vdomain[simp]: "A ^⇩× 0 = set {0}"
by (auto simp: scalar_nop)
text‹Rules.›
lemmas scalarI[intro] = scalar.intro
lemma scalarD[dest]:
assumes "scalar A f"
shows "nop A 0 f"
using assms unfolding scalar_def by auto
lemma scalarE[elim]:
assumes "scalar A f"
obtains "nop A 0 f"
using assms by auto
subsection‹Unary operation›
locale unop = nop A ‹1⇩ℕ› f for A f
text‹Rules.›
lemmas unopI[intro] = unop.intro
lemma unopD[dest]:
assumes "unop A f"
shows "nop A (1⇩ℕ) f"
using assms unfolding unop_def by auto
lemma unopE[elim]:
assumes "unop A f"
obtains "nop A (1⇩ℕ) f"
using assms by blast
subsection‹Injective unary operation›
locale unop_v11 = nop_v11 A ‹1⇩ℕ› f for A f
sublocale unop_v11 ⊆ unop A f by (intro unopI) (simp add: nop_axioms)
text‹Rules.›
lemma unop_v11I[intro]:
assumes "nop_v11 A (1⇩ℕ) f"
shows "unop_v11 A f"
using assms by (rule unop_v11.intro)
lemma unop_v11D[dest]:
assumes "unop_v11 A f"
shows "nop_v11 A (1⇩ℕ) f"
using assms by (rule unop_v11.axioms)
lemma unop_v11E[elim]:
assumes "unop_v11 A f"
obtains "nop_v11 A (1⇩ℕ) f"
using assms by blast
subsection‹Surjective unary operation›
locale unop_onto = nop_onto A ‹1⇩ℕ› f for A f
sublocale unop_onto ⊆ unop A f by (intro unopI) (simp add: nop_axioms)
text‹Rules.›
lemma unop_ontoI[intro]:
assumes "nop_onto A (1⇩ℕ) f"
shows "unop_onto A f"
using assms by (rule unop_onto.intro)
lemma unop_ontoD[dest]:
assumes "unop_onto A f"
shows "nop_onto A (1⇩ℕ) f"
using assms by (rule unop_onto.axioms)
lemma unop_ontoE[elim]:
assumes "unop_onto A f"
obtains "nop_onto A (1⇩ℕ) f"
using assms by blast
lemma unop_ontoI'[intro]:
assumes "unop A f" and "A ⊆⇩∘ ℛ⇩∘ f"
shows "unop_onto A f"
proof-
interpret unop A f by (rule assms(1))
from assms(2) nop_vrange have "A = ℛ⇩∘ f" by simp
with assms(1) show "unop_onto A f" by auto
qed
subsection‹Bijective unary operation›
locale unop_bij = nop_bij A ‹1⇩ℕ› f for A f
sublocale unop_bij ⊆ unop_v11 A f
by (intro unop_v11I) (simp add: nop_v11_axioms)
sublocale unop_bij ⊆ unop_onto A f
by (intro unop_ontoI) (simp add: nop_onto_axioms)
text‹Rules.›
lemma unop_bijI[intro]:
assumes "nop_bij A (1⇩ℕ) f"
shows "unop_bij A f"
using assms by (rule unop_bij.intro)
lemma unop_bijD[dest]:
assumes "unop_bij A f"
shows "nop_bij A (1⇩ℕ) f"
using assms by (rule unop_bij.axioms)
lemma unop_bijE[elim]:
assumes "unop_bij A f"
obtains "nop_bij A (1⇩ℕ) f"
using assms by blast
lemma unop_bijI'[intro]:
assumes "unop_v11 A f" and "A ⊆⇩∘ ℛ⇩∘ f"
shows "unop_bij A f"
proof-
interpret unop_v11 A f by (rule assms(1))
from assms(2) nop_vrange have "A = ℛ⇩∘ f" by simp
with assms(1) show "unop_bij A f" by auto
qed
subsection‹Partial binary operation›
locale pbinop = pnop A ‹2⇩ℕ› f for A f
sublocale pbinop ⊆ dom: fbrelation ‹𝒟⇩∘ f›
proof
from pnop_vdomain show "fpairs (𝒟⇩∘ f) = 𝒟⇩∘ f"
by (intro vsubset_antisym vsubsetI) auto
qed
text‹Rules.›
lemmas pbinopI[intro] = pbinop.intro
lemma pbinopD[dest]:
assumes "pbinop A f"
shows "pnop A (2⇩ℕ) f"
using assms unfolding pbinop_def by auto
lemma pbinopE[elim]:
assumes "pbinop A f"
obtains "pnop A (2⇩ℕ) f"
using assms by auto
text‹Elementary properties.›
lemma (in pbinop) fbinop_vcard:
assumes "x ∈⇩∘ 𝒟⇩∘ f"
shows "vcard x = 2⇩ℕ"
proof-
from assms dom.fbrelation_axioms obtain a b where x_def: "x = [a, b]⇩∘" by blast
show ?thesis by (auto simp: x_def nat_omega_simps)
qed
subsection‹Total binary operation›
locale binop = nop A ‹2⇩ℕ› f for A f
sublocale binop ⊆ pbinop by unfold_locales
text‹Rules.›
lemmas binopI[intro] = binop.intro
lemma binopD[dest]:
assumes "binop A f"
shows "nop A (2⇩ℕ) f"
using assms unfolding binop_def by auto
lemma binopE[elim]:
assumes "binop A f"
obtains "nop A (2⇩ℕ) f"
using assms by auto
text‹Elementary properties.›
lemma (in binop) binop_app_in_vrange[intro]:
assumes "a ∈⇩∘ A" and "b ∈⇩∘ A"
shows "f⦇a, b⦈⇩∙ ∈⇩∘ ℛ⇩∘ f"
proof-
from assms have "[a, b]⇩∘ ∈⇩∘ A ^⇩× 2⇩ℕ" by (auto simp: nat_omega_simps)
then show ?thesis by (simp add: nop_vdomain vsv_vimageI2)
qed
subsection‹Injective binary operation›
locale binop_v11 = nop_v11 A ‹2⇩ℕ› f for A f
sublocale binop_v11 ⊆ binop A f by (intro binopI) (simp add: nop_axioms)
text‹Rules.›
lemma binop_v11I[intro]:
assumes "nop_v11 A (2⇩ℕ) f"
shows "binop_v11 A f"
using assms by (rule binop_v11.intro)
lemma binop_v11D[dest]:
assumes "binop_v11 A f"
shows "nop_v11 A (2⇩ℕ) f"
using assms by (rule binop_v11.axioms)
lemma binop_v11E[elim]:
assumes "binop_v11 A f"
obtains "nop_v11 A (2⇩ℕ) f"
using assms by blast
subsection‹Surjective binary operation›
locale binop_onto = nop_onto A ‹2⇩ℕ› f for A f
sublocale binop_onto ⊆ binop A f by (intro binopI) (simp add: nop_axioms)
text‹Rules.›
lemma binop_ontoI[intro]:
assumes "nop_onto A (2⇩ℕ) f"
shows "binop_onto A f"
using assms by (rule binop_onto.intro)
lemma binop_ontoD[dest]:
assumes "binop_onto A f"
shows "nop_onto A (2⇩ℕ) f"
using assms by (rule binop_onto.axioms)
lemma binop_ontoE[elim]:
assumes "binop_onto A f"
obtains "nop_onto A (2⇩ℕ) f"
using assms by blast
lemma binop_ontoI'[intro]:
assumes "binop A f" and "A ⊆⇩∘ ℛ⇩∘ f"
shows "binop_onto A f"
proof-
interpret binop A f by (rule assms(1))
from assms(2) nop_vrange have "A = ℛ⇩∘ f" by simp
with assms(1) show "binop_onto A f" by auto
qed
subsection‹Bijective binary operation›
locale binop_bij = nop_bij A ‹2⇩ℕ› f for A f
sublocale binop_bij ⊆ binop_v11 A f
by (intro binop_v11I) (simp add: nop_v11_axioms)
sublocale binop_bij ⊆ binop_onto A f
by (intro binop_ontoI) (simp add: nop_onto_axioms)
text‹Rules.›
lemma binop_bijI[intro]:
assumes "nop_bij A (2⇩ℕ) f"
shows "binop_bij A f"
using assms by (rule binop_bij.intro)
lemma binop_bijD[dest]:
assumes "binop_bij A f"
shows "nop_bij A (2⇩ℕ) f"
using assms by (rule binop_bij.axioms)
lemma binop_bijE[elim]:
assumes "binop_bij A f"
obtains "nop_bij A (2⇩ℕ) f"
using assms by blast
lemma binop_bijI'[intro]:
assumes "binop_v11 A f" and "A ⊆⇩∘ ℛ⇩∘ f"
shows "binop_bij A f"
proof-
interpret binop_v11 A f by (rule assms(1))
from assms(2) nop_vrange have "A = ℛ⇩∘ f" by simp
with assms(1) show "binop_bij A f" by auto
qed
subsection‹Flip›
definition fflip :: "V ⇒ V"
where "fflip f = (λab∈⇩∘(𝒟⇩∘ f)¯⇩∙. f⦇ab⦇1⇩ℕ⦈, ab⦇0⦈⦈⇩∙)"
text‹Elementary properties.›
lemma fflip_vsv: "vsv (fflip f)"
by (intro vsvI) (auto simp: fflip_def)
lemma vdomain_fflip[simp]: "𝒟⇩∘ (fflip f) = (𝒟⇩∘ f)¯⇩∙"
unfolding fflip_def by simp
lemma (in pbinop) vrange_fflip: "ℛ⇩∘ (fflip f) = ℛ⇩∘ f"
unfolding fflip_def
proof(intro vsubset_antisym vsubsetI)
fix y assume "y ∈⇩∘ ℛ⇩∘ ((λx∈⇩∘(𝒟⇩∘ f)¯⇩∙. f⦇x⦇1⇩ℕ⦈, x⦇0⦈⦈⇩∙))"
then obtain x where "x ∈⇩∘ (𝒟⇩∘ f)¯⇩∙" and y_def: "y = f⦇x⦇1⇩ℕ⦈, x⦇0⦈⦈⇩∙" by fast
then obtain a b where x_def: "x = [b, a]⇩∘" by clarsimp
have y_def': "y = f⦇a, b⦈⇩∙"
unfolding y_def x_def by (simp add: nat_omega_simps)
from x_def ‹x ∈⇩∘ (𝒟⇩∘ f)¯⇩∙› have "[a, b]⇩∘ ∈⇩∘ 𝒟⇩∘ f" by clarsimp
then show "y ∈⇩∘ ℛ⇩∘ f" unfolding y_def' by (simp add: vsv_vimageI2)
next
fix y assume "y ∈⇩∘ ℛ⇩∘ f"
with vrange_atD obtain x where x: "x ∈⇩∘ 𝒟⇩∘ f" and y_def: "y = f⦇x⦈" by blast
with dom.fbrelation obtain a b where x_def: "x = [a, b]⇩∘" by blast
from x have ba: "[b, a]⇩∘ ∈⇩∘ (𝒟⇩∘ f)¯⇩∙" unfolding x_def by clarsimp
then have y_def': "y = f⦇[b, a]⇩∘⦇1⇩ℕ⦈, [b, a]⇩∘⦇0⦈⦈⇩∙"
unfolding y_def x_def by (auto simp: nat_omega_simps)
then show "y ∈⇩∘ ℛ⇩∘ ((λab∈⇩∘(𝒟⇩∘ f)¯⇩∙. f⦇ab⦇1⇩ℕ⦈, ab⦇0⦈⦈⇩∙))"
unfolding y_def'
by (metis (lifting) ba beta rel_VLambda.vsv_vimageI2 vdomain_VLambda)
qed
lemma fflip_app[simp]:
assumes "[a, b]⇩∘ ∈⇩∘ 𝒟⇩∘ f"
shows "fflip f⦇b, a⦈⇩∙ = f⦇a, b⦈⇩∙"
proof-
from assms have "[b, a]⇩∘ ∈⇩∘ 𝒟⇩∘ (fflip f)" by clarsimp
then show "fflip f⦇b, a⦈⇩∙ = f⦇a, b⦈⇩∙"
by (simp add: fflip_def ord_of_nat_succ_vempty)
qed
lemma (in pbinop) pbinop_fflip_fflip: "fflip (fflip f) = f"
proof(rule vsv_eqI)
show "vsv (fflip (fflip f))" by (simp add: fflip_vsv)
show "vsv f" by (rule vsv_axioms)
show dom: "𝒟⇩∘ (fflip (fflip f)) = 𝒟⇩∘ f" by simp
fix x assume prems: "x ∈⇩∘ 𝒟⇩∘ (fflip (fflip f))"
with dom dom.fbrelation_axioms obtain a b where x_def: "x = [a, b]⇩∘" by auto
from prems show "fflip (fflip f)⦇x⦈ = f⦇x⦈"
unfolding x_def by (auto simp: fconverseI)
qed
lemma (in binop) pbinop_fflip_app[simp]:
assumes "a ∈⇩∘ A" and "b ∈⇩∘ A"
shows "fflip f⦇b, a⦈⇩∙ = f⦇a, b⦈⇩∙"
proof-
from assms have "[a, b]⇩∘ ∈⇩∘ 𝒟⇩∘ f"
unfolding nop_vdomain by (auto simp: nat_omega_simps)
then show ?thesis by auto
qed
lemma fflip_vsingleton: "fflip (set {⟨[a, b]⇩∘, c⟩}) = set {⟨[b, a]⇩∘, c⟩}"
proof-
have dom_lhs: "𝒟⇩∘ (fflip (set {⟨[a, b]⇩∘, c⟩})) = set {[b, a]⇩∘}"
unfolding fflip_def by auto
have dom_rhs: "𝒟⇩∘ (set {⟨[b, a]⇩∘, c⟩}) = set {[b, a]⇩∘}" by simp
show ?thesis
proof(rule vsv_eqI, unfold dom_lhs dom_rhs)
fix q assume "q ∈⇩∘ set {[b, a]⇩∘}"
then have q_def: "q = [b, a]⇩∘" by simp
show "fflip (set {⟨[a, b]⇩∘, c⟩})⦇q⦈ = set {⟨[b, a]⇩∘, c⟩}⦇q⦈"
unfolding q_def by auto
qed (auto simp: fflip_def)
qed
text‹\newpage›
end
Theory HOL_CContinuum
section‹Intermission: upper bound on the cardinality of the continuum (HOL)›
theory HOL_CContinuum
imports CZH_Sets_Introduction
begin
text‹
The section presents a proof of ‹|ℝ|≤|𝒫(ℕ)|› in Isabelle/HOL. The proof is
based on an outline at the beginning of Chapter 4 in the textbook
‹Set Theory› by Thomas Jech \cite{jech_set_2006}.
›
lemma Pow_lepoll_mono:
assumes "A ≲ B"
shows "Pow A ≲ Pow B"
using assms by (metis Pow_mono image_Pow_surj lepoll_iff)
lemma rat_lepoll_nat: "(UNIV::rat set) ≲ (UNIV::nat set)"
unfolding lepoll_def by auto
definition rcut :: "real ⇒ real set" where "rcut r = {x∈ℚ. x < r}"
lemma inj_rcut: "inj rcut"
unfolding rcut_def
proof(intro inj_onI)
have xy: "x < y ⟹ {r∈ℚ. r < x} = {r∈ℚ. r < y} ⟹ x = y" for x y :: real
proof(rule ccontr)
assume prems: "x < y" "{r∈ℚ. r < x} = {r∈ℚ. r < y}"
then have "{r∈ℚ. r < y} - {r∈ℚ. r < x} = {}" by simp
with prems(1) Rats_dense_in_real show False by force
qed
then have yx: "y < x ⟹ {r∈ℚ. r < x} = {r∈ℚ. r < y} ⟹ x = y"
for x y :: real
by auto
show "{z ∈ ℚ. z < x} = {z ∈ ℚ. z < y} ⟹ x = y" for x y :: real
proof(rule ccontr)
fix x y :: real assume prems: "{xa ∈ ℚ. xa < x} = {x ∈ ℚ. x < y}" "x ≠ y"
from this(2) consider "x < y" | "y < x" by force
with xy[OF _ prems(1)] yx[OF _ prems(1)] show False by cases auto
qed
qed
lemma range_rcut_subset_Pow_rat: "range rcut ⊆ Pow ℚ"
proof(intro subsetI)
fix x assume "x ∈ range rcut"
then obtain r where "x = {x∈ℚ. x < r}" unfolding rcut_def by clarsimp
then show "x ∈ Pow ℚ" by simp
qed
lemma inj_on_inv_of_rat_rat: "inj_on (inv of_rat) ℚ"
using inv_into_injective by (intro inj_onI) (fastforce simp: Rats_def)
lemma inj_on_inv_image_inv_of_rat_Pow_rat: "inj_on (image (inv of_rat)) (Pow ℚ)"
by (simp add: inj_on_inv_of_rat_rat inj_on_image_Pow)
lemma inj_on_image_inv_of_rat_range_rcut:
"inj_on (image (inv of_rat)) (range rcut)"
using range_rcut_subset_Pow_rat inj_on_inv_image_inv_of_rat_Pow_rat
by (auto intro: inj_on_subset)
lemma real_lepoll_ratrat: "(UNIV::real set) ≲ (UNIV::rat set set)"
unfolding lepoll_def
proof(intro exI conjI)
from inj_rcut inj_on_image_inv_of_rat_range_rcut show
"inj (image (inv of_rat) ∘ rcut)"
by (rule comp_inj_on)
qed auto
lemma nat_lepoll_real: "(UNIV::nat set) ≲ (UNIV::real set)"
using infinite_UNIV_char_0 infinite_countable_subset
unfolding lepoll_def
by blast
lemma real_lepoll_natnat: "(UNIV::real set) ≲ Pow (UNIV::nat set)"
proof-
have "(UNIV::rat set set) ≲ (UNIV::nat set set)"
unfolding Pow_UNIV[symmetric] by (intro Pow_lepoll_mono rat_lepoll_nat)
from lepoll_trans[OF real_lepoll_ratrat this] show ?thesis by simp
qed
text‹\newpage›
end
Theory CZH_Sets_ZQR
section‹
Construction of integer numbers, rational numbers and real numbers
›
theory CZH_Sets_ZQR
imports
"HOL-Library.Rewrite"
CZH_Sets_NOP
CZH_Sets_VNHS
HOL_CContinuum
begin
subsection‹Background›
text‹
The set of real numbers ‹ℝ⇩∘› is defined in a way such that it agrees
with the set of natural numbers \<^const>‹ω›. However, otherwise,
real numbers are allowed to be arbitrary sets
in \<^term>‹Vset (ω + ω)›.\footnote{
The idea itself is not new, e.g., see \cite{chen_hotg_2021}.
}
Integer and rational numbers are exposed via canonical injections into
the set of real numbers from the types \<^typ>‹int› and \<^typ>‹rat›, respectively.
Lastly, common operations on the real, integer and rational numbers
are defined and some of their main properties are exposed.
The primary reference for this section is the textbook
‹The Real Numbers and Real Analysis› by E. Bloch
\cite{bloch_real_2010}. Nonetheless, it is not claimed that the exposition of
the subject presented in this section is entirely congruent with the exposition
in the aforementioned reference.
›
declare One_nat_def[simp del]
named_theorems vnumber_simps
lemmas [vnumber_simps] =
Collect_mem_eq Ball_def[symmetric] Bex_def[symmetric] vsubset_eq[symmetric]
text‹
Supplementary material for the evaluation of the upper bound of the
cardinality of the continuum.
›
lemma inj_image_ord_of_nat: "inj (image ord_of_nat)"
by (intro injI) (simp add: inj_image_eq_iff inj_ord_of_nat)
lemma vlepoll_VPow_omega_if_vreal_lepoll_real:
assumes "x ≲ (UNIV::real set)"
shows "set x ≲⇩∘ VPow ω"
proof-
note x = assms
also from real_lepoll_natnat have "… ≲ (UNIV::nat set set)"
unfolding Pow_UNIV by simp
also from inj_image_ord_of_nat have "… ≲ Pow (elts ω)"
unfolding lepoll_def by auto
also from down have "… ≲ elts (VPow ω)"
unfolding lepoll_def
by (intro exI[of _ set] conjI inj_onI) (auto simp: elts_VPow)
finally show "set x ≲⇩∘ VPow ω" by simp
qed
subsection‹Real numbers›
subsubsection‹Definition›
abbreviation real :: "nat ⇒ real"
where "real ≡ of_nat"
definition nat_of_real :: "real ⇒ nat"
where "nat_of_real = inv_into UNIV real"
definition vreal_of_real_impl :: "real ⇒ V"
where "vreal_of_real_impl = (SOME V_of::real⇒V. inj V_of)"
lemma inj_vreal_of_real_impl: "inj vreal_of_real_impl"
unfolding vreal_of_real_impl_def
by (metis embeddable_class.ex_inj verit_sko_ex')
lemma inj_on_inv_vreal_of_real_impl:
"inj_on (inv vreal_of_real_impl) (range vreal_of_real_impl)"
by (intro inj_onI) (fastforce intro: inv_into_injective)
lemma range_vreal_of_real_impl_vlepoll_VPow_omega:
"set (range vreal_of_real_impl) ≲⇩∘ VPow ω"
proof-
have "range vreal_of_real_impl ≲ (UNIV::real set)"
unfolding lepoll_def by (auto intro: inj_on_inv_vreal_of_real_impl)
from vlepoll_VPow_omega_if_vreal_lepoll_real[OF this] show ?thesis .
qed
definition vreal_impl :: V
where "vreal_impl =
(
SOME y.
range vreal_of_real_impl ≈ elts y ∧
vdisjnt y ω ∧
y ∈⇩∘ Vset (ω + ω)
)"
lemma vreal_impl_eqpoll: "range vreal_of_real_impl ≈ elts vreal_impl"
and vreal_impl_vdisjnt: "vdisjnt vreal_impl ω"
and vreal_impl_in_Vset_ss_omega: "vreal_impl ∈⇩∘ Vset (ω + ω)"
proof-
from Ord_ω have VPow_in_Vset: "VPow ω ∈⇩∘ Vset (succ (succ ω))"
by (intro Ord_VPow_in_Vset_succI)
(auto simp: less_TC_succ Ord_iff_rank VsetI)
have [simp]: "small (range vreal_of_real_impl)" by simp
then obtain x where x: "range vreal_of_real_impl = elts x"
unfolding small_iff by clarsimp
from range_vreal_of_real_impl_vlepoll_VPow_omega[unfolded x] have
"x ≲⇩∘ VPow ω"
by simp
then obtain f where "v11 f" and "𝒟⇩∘ f = x" and "ℛ⇩∘ f ⊆⇩∘ VPow ω" by auto
moreover have Oω2: "Ord (succ (succ ω))" by auto
ultimately have x_Rf: "x ≈⇩∘ ℛ⇩∘ f" and "ℛ⇩∘ f ∈⇩∘ Vset (succ (succ ω))"
by (auto intro: VPow_in_Vset)
then have "ω ∪⇩∘ ℛ⇩∘ f ∈⇩∘ Vset (succ (succ ω))" and "ℛ⇩∘ f ⊆⇩∘ ω ∪⇩∘ ℛ⇩∘ f"
by (auto simp: VPow_in_Vset VPow_in_Vset_revD vunion_in_VsetI)
from Ord_ex_eqpoll_vdisjnt[OF Oω2 this(2,1)] obtain z
where Rf_z: "ℛ⇩∘ f ≈⇩∘ z"
and "vdisjnt z (ω ∪⇩∘ ℛ⇩∘ f)"
and z: "z ⊆⇩∘ Vset (succ (succ (succ ω)))"
by auto
then have vdisjnt_zω: "vdisjnt z ω"
and z_ssssω: "z ∈⇩∘ Vset (succ (succ (succ (succ ω))))"
by
(
auto simp:
vdisjnt_vunion_right vsubset_in_VsetI Ord_succ Ord_Vset_in_Vset_succI
)
have "Limit (ω + ω)" by simp
then have "succ (succ (succ (succ ω))) ∈⇩∘ ω + ω"
by (metis Limit_def add.right_neutral add_mem_right_cancel Limit_omega)
then have "Vset (succ (succ (succ (succ ω)))) ∈⇩∘ Vset (ω + ω)"
by (simp add: Vset_in_mono)
with z z_ssssω have "z ∈⇩∘ Vset (ω + ω)" by auto
moreover from x_Rf Rf_z have "range vreal_of_real_impl ≈ elts z"
unfolding x by (auto intro: eqpoll_trans)
ultimately show "range vreal_of_real_impl ≈ elts vreal_impl"
and "vdisjnt vreal_impl ω"
and "vreal_impl ∈⇩∘ Vset (ω + ω)"
using vdisjnt_zω
unfolding vreal_impl_def
by (metis (mono_tags, lifting) verit_sko_ex')+
qed
definition vreal_of_real_impl' :: "V ⇒ V"
where "vreal_of_real_impl' =
(SOME f. bij_betw f (range vreal_of_real_impl) (elts vreal_impl))"
lemma vreal_of_real_impl'_bij_betw:
"bij_betw vreal_of_real_impl' (range vreal_of_real_impl) (elts vreal_impl)"
proof-
from eqpoll_def obtain f where f:
"bij_betw f (range vreal_of_real_impl) (elts vreal_impl)"
by (auto intro: vreal_impl_eqpoll)
then show ?thesis unfolding vreal_of_real_impl'_def by (metis verit_sko_ex')
qed
definition vreal_of_real_impl'' :: "real ⇒ V"
where "vreal_of_real_impl'' = vreal_of_real_impl' ∘ vreal_of_real_impl"
lemma vreal_of_real_impl'': "disjnt (range vreal_of_real_impl'') (elts ω)"
proof-
from comp_apply vreal_impl_vdisjnt vreal_of_real_impl'_bij_betw have
"vreal_of_real_impl'' y ∉⇩∘ ω" for y
unfolding vreal_of_real_impl''_def by fastforce
then show ?thesis unfolding disjnt_iff by clarsimp
qed
lemma inj_vreal_of_real_impl'': "inj vreal_of_real_impl''"
unfolding vreal_of_real_impl''_def
by
(
meson
bij_betwE
comp_inj_on
inj_vreal_of_real_impl
vreal_of_real_impl'_bij_betw
)
text‹Main definitions.›
definition vreal_of_real :: "real ⇒ V"
where "vreal_of_real x =
(if x ∈ ℕ then (nat_of_real x)⇩ℕ else vreal_of_real_impl'' x)"
notation vreal_of_real (‹_⇩ℝ› [1000] 999)
declare [[coercion "vreal_of_real :: real ⇒ V"]]
definition vreal :: V (‹ℝ⇩∘›)
where "vreal = set (range vreal_of_real)"
definition real_of_vreal :: "V ⇒ real"
where "real_of_vreal = inv_into UNIV vreal_of_real"
text‹Rules.›
lemma vreal_of_real_in_vrealI[intro, simp]: "a⇩ℝ ∈⇩∘ ℝ⇩∘"
by (simp add: vreal_def)
lemma vreal_of_real_in_vrealE[elim]:
assumes "a ∈⇩∘ ℝ⇩∘"
obtains b where "b⇩ℝ = a"
using assms unfolding vreal_def by auto
text‹Elementary properties.›
lemma vnat_eq_vreal: "x⇩ℕ = x⇩ℝ" by (simp add: nat_of_real_def vreal_of_real_def)
lemma omega_vsubset_vreal: "ω ⊆⇩∘ ℝ⇩∘"
proof
fix x assume "x ∈⇩∘ ω"
with nat_of_omega obtain y where x_def: "x = y⇩ℕ" by auto
then have "vreal_of_real (real y) = (nat_of_real (real y))⇩ℕ"
unfolding vreal_of_real_def by simp
moreover have "(nat_of_real (real y))⇩ℕ = x"
by (simp add: nat_of_real_def x_def)
ultimately show "x ∈⇩∘ ℝ⇩∘" unfolding vreal_def by clarsimp
qed
lemma inj_vreal_of_real: "inj vreal_of_real"
proof
fix x y assume prems: "vreal_of_real x = vreal_of_real y"
consider
(xy) ‹x ∈ ℕ ∧ y ∈ ℕ› |
(x_ny) ‹x ∈ ℕ ∧ y ∉ ℕ› |
(nx_y) ‹x ∉ ℕ ∧ y ∈ ℕ› |
(nxy) ‹x ∉ ℕ ∧ y ∉ ℕ›
by auto
then show "x = y"
proof cases
case xy
then have "(nat_of_real x)⇩ℕ = (nat_of_real y)⇩ℕ"
using vreal_of_real_def prems by simp
then show ?thesis
by (metis Nats_def f_inv_into_f nat_of_real_def ord_of_nat_inject xy)
next
case x_ny
with prems have eq: "(nat_of_real x)⇩ℕ = vreal_of_real_impl'' y"
unfolding vreal_of_real_def by simp
have "vreal_of_real_impl'' y ∉⇩∘ ω"
by (meson disjnt_iff rangeI vreal_of_real_impl'')
then show ?thesis unfolding eq[symmetric] by auto
next
case nx_y
with prems have eq: "(nat_of_real y)⇩ℕ = vreal_of_real_impl'' x"
unfolding vreal_of_real_def by simp
have "vreal_of_real_impl'' x ∉⇩∘ ω"
by (meson disjnt_iff rangeI vreal_of_real_impl'')
then show ?thesis unfolding eq[symmetric] by auto
next
case nxy
then have "x ∉ ℕ" and "y ∉ ℕ" by auto
with prems
have "vreal_of_real_impl'' x = vreal_of_real_impl'' y"
unfolding vreal_of_real_def by simp
then show ?thesis by (meson inj_def inj_vreal_of_real_impl'')
qed
qed
lemma vreal_in_Vset_ω2: "ℝ⇩∘ ∈⇩∘ Vset (ω + ω)"
unfolding vreal_def
proof-
have "set (range vreal_of_real) ⊆⇩∘ set (range vreal_of_real_impl'') ∪⇩∘ ω"
unfolding vreal_of_real_def by auto
moreover from vreal_of_real_impl'_bij_betw have
"set (range vreal_of_real_impl'') ⊆⇩∘ vreal_impl"
unfolding vreal_of_real_impl''_def by fastforce
ultimately show "set (range vreal_of_real) ∈⇩∘ Vset (ω + ω)"
using Ord_ω Ord_add
by
(
auto simp:
Ord_iff_rank
Ord_VsetI
vreal_impl_in_Vset_ss_omega
vsubset_in_VsetI
vunion_in_VsetI
)
qed
lemma real_of_vreal_vreal_of_real[simp]: "real_of_vreal (a⇩ℝ) = a"
by (simp add: inj_vreal_of_real real_of_vreal_def)
subsubsection‹Transfer rules›
definition cr_vreal :: "V ⇒ real ⇒ bool"
where "cr_vreal a b ⟷ (a = vreal_of_real b)"
lemma cr_vreal_right_total[transfer_rule]: "right_total cr_vreal"
unfolding cr_vreal_def right_total_def by simp
lemma cr_vreal_bi_uniqie[transfer_rule]: "bi_unique cr_vreal"
unfolding cr_vreal_def bi_unique_def
by (simp add: inj_eq inj_vreal_of_real)
lemma cr_vreal_transfer_domain_rule[transfer_domain_rule]:
"Domainp cr_vreal = (λx. x ∈⇩∘ ℝ⇩∘)"
unfolding cr_vreal_def by force
lemma vreal_transfer[transfer_rule]:
"(rel_set cr_vreal) (elts ℝ⇩∘) (UNIV::real set)"
unfolding cr_vreal_def rel_set_def by auto
lemma vreal_of_real_transfer[transfer_rule]: "cr_vreal (vreal_of_real a) a"
unfolding cr_vreal_def by auto
subsubsection‹Constants and operations›
text‹Auxiliary.›
lemma vreal_fsingleton_in_fproduct_vreal: "[a⇩ℝ]⇩∘ ∈⇩∘ ℝ⇩∘ ^⇩× 1⇩ℕ" by auto
lemma vreal_fpair_in_fproduct_vreal: "[a⇩ℝ, b⇩ℝ]⇩∘ ∈⇩∘ ℝ⇩∘ ^⇩× 2⇩ℕ" by force
text‹Zero.›
lemma vreal_zero: "0⇩ℝ = (0::V)"
by (simp add: ord_of_nat_vempty vnat_eq_vreal)
text‹One.›
lemma vreal_one: "1⇩ℝ = (1::V)"
by (simp add: ord_of_nat_vone vnat_eq_vreal)
text‹Addition.›
definition vreal_plus :: V
where "vreal_plus =
(λx∈⇩∘ℝ⇩∘ ^⇩× 2⇩ℕ. (real_of_vreal (x⦇0⇩ℕ⦈) + real_of_vreal (x⦇1⇩ℕ⦈))⇩ℝ)"
abbreviation vreal_plus_app :: "V ⇒ V ⇒ V" (infixl "+⇩ℝ" 65)
where "vreal_plus_app a b ≡ vreal_plus⦇a, b⦈⇩∙"
notation vreal_plus_app (infixl "+⇩ℝ" 65)
lemma vreal_plus_transfer[transfer_rule]:
includes lifting_syntax
shows "(cr_vreal ===> cr_vreal ===> cr_vreal)
(+⇩ℝ) (+)"
using vreal_fpair_in_fproduct_vreal
by (intro rel_funI, unfold vreal_plus_def cr_vreal_def cr_scalar_def)
(simp add: nat_omega_simps)
text‹Multiplication.›
definition vreal_mult :: V
where "vreal_mult =
(λx∈⇩∘ℝ⇩∘ ^⇩× 2⇩ℕ. (real_of_vreal (x⦇0⇩ℕ⦈) * real_of_vreal (x⦇1⇩ℕ⦈))⇩ℝ)"
abbreviation vreal_mult_app (infixl "*⇩ℝ" 70)
where "vreal_mult_app a b ≡ vreal_mult⦇a, b⦈⇩∙"
notation vreal_mult_app (infixl "*⇩ℝ" 70)
lemma vreal_mult_transfer[transfer_rule]:
includes lifting_syntax
shows "(cr_vreal ===> cr_vreal ===> cr_vreal) (*⇩ℝ) (*)"
using vreal_fpair_in_fproduct_vreal
by (intro rel_funI, unfold vreal_mult_def cr_vreal_def cr_scalar_def)
(simp add: nat_omega_simps)
text‹Unary minus.›
definition vreal_uminus :: V
where "vreal_uminus = (λx∈⇩∘ℝ⇩∘. (uminus (real_of_vreal x))⇩ℝ)"
abbreviation vreal_uminus_app (‹-⇩ℝ _› [81] 80)
where "-⇩ℝ a ≡ vreal_uminus⦇a⦈"
lemma vreal_uminus_transfer[transfer_rule]:
includes lifting_syntax
shows "(cr_vreal ===> cr_vreal) (vreal_uminus_app) (uminus)"
using vreal_fsingleton_in_fproduct_vreal
by (intro rel_funI, unfold vreal_uminus_def cr_vreal_def cr_scalar_def)
(simp add: nat_omega_simps)
text‹Multiplicative inverse.›
definition vreal_inverse :: V
where "vreal_inverse = (λx∈⇩∘ℝ⇩∘. (inverse (real_of_vreal x))⇩ℝ)"
abbreviation vreal_inverse_app (‹(_¯⇩ℝ)› [1000] 999)
where "a¯⇩ℝ ≡ vreal_inverse⦇a⦈"
lemma vreal_inverse_transfer[transfer_rule]:
includes lifting_syntax
shows "(cr_vreal ===> cr_vreal) (vreal_inverse_app) (inverse)"
using vreal_fsingleton_in_fproduct_vreal
by (intro rel_funI, unfold vreal_inverse_def cr_vreal_def cr_scalar_def)
(simp add: nat_omega_simps)
text‹Order.›
definition vreal_le :: V
where "vreal_le =
set {[a, b]⇩∘ | a b. [a, b]⇩∘ ∈⇩∘ ℝ⇩∘ ^⇩× 2⇩ℕ ∧ real_of_vreal a ≤ real_of_vreal b}"
abbreviation vreal_le' (‹(_/ ≤⇩ℝ _)› [51, 51] 50)
where "a ≤⇩ℝ b ≡ [a, b]⇩∘ ∈⇩∘ vreal_le"
lemma small_vreal_le[simp]:
"small
{[a, b]⇩∘ | a b. [a, b]⇩∘ ∈⇩∘ ℝ⇩∘ ^⇩× 2⇩ℕ ∧ real_of_vreal a ≤ real_of_vreal b}"
proof-
have small: "small {[a, b]⇩∘ | a b. [a, b]⇩∘ ∈⇩∘ ℝ⇩∘ ^⇩× 2⇩ℕ}" by simp
show ?thesis by (rule smaller_than_small[OF small]) auto
qed
lemma vreal_le_transfer[transfer_rule]:
includes lifting_syntax
shows "(cr_vreal ===> cr_vreal ===> (=)) vreal_le' (≤)"
using vreal_fsingleton_in_fproduct_vreal
by (intro rel_funI, unfold cr_scalar_def cr_vreal_def vreal_le_def)
(auto simp: nat_omega_simps)
text‹Strict order.›
definition vreal_ls :: V
where "vreal_ls =
set {[a, b]⇩∘ | a b. [a, b]⇩∘ ∈⇩∘ ℝ⇩∘ ^⇩× 2⇩ℕ ∧ real_of_vreal a < real_of_vreal b}"
abbreviation vreal_ls' (‹(_/ <⇩ℝ _)› [51, 51] 50)
where "a <⇩ℝ b ≡ [a, b]⇩∘ ∈⇩∘ vreal_ls"
lemma small_vreal_ls[simp]:
"small
{[a, b]⇩∘ | a b. [a, b]⇩∘ ∈⇩∘ ℝ⇩∘ ^⇩× 2⇩ℕ ∧ real_of_vreal a < real_of_vreal b}"
proof-
have small: "small {[a, b]⇩∘ | a b. [a, b]⇩∘ ∈⇩∘ ℝ⇩∘ ^⇩× 2⇩ℕ}" by simp
show ?thesis by (rule smaller_than_small[OF small]) auto
qed
lemma vreal_ls_transfer[transfer_rule]:
includes lifting_syntax
shows "(cr_vreal ===> cr_vreal ===> (=)) vreal_ls' (<)"
by (intro rel_funI, unfold cr_scalar_def cr_vreal_def vreal_ls_def)
(auto simp: nat_omega_simps)
text‹Subtraction.›
definition vreal_minus :: V
where "vreal_minus =
(λx∈⇩∘ℝ⇩∘ ^⇩× 2⇩ℕ. (real_of_vreal (x⦇0⇩ℕ⦈) - real_of_vreal (x⦇1⇩ℕ⦈))⇩ℝ)"
abbreviation vreal_minus_app (infixl "-⇩ℝ" 65)
where "vreal_minus_app a b ≡ vreal_minus⦇a, b⦈⇩∙"
lemma vreal_minus_transfer[transfer_rule]:
includes lifting_syntax
shows "(cr_vreal ===> cr_vreal ===> cr_vreal) (-⇩ℝ) (-)"
using vreal_fpair_in_fproduct_vreal
by (intro rel_funI, unfold vreal_minus_def cr_vreal_def cr_scalar_def)
(simp add: nat_omega_simps)
subsubsection‹Axioms of an ordered field with the least upper bound property.›
text‹
The exposition follows the Definitions 2.2.1 and 2.2.3 from
the textbook ‹The Real Numbers and Real Analysis› by E. Bloch
\cite{bloch_real_2010}.
›
lemma vreal_zero_closed: "0⇩ℝ ∈⇩∘ ℝ⇩∘"
proof-
have "(0::real) ∈ UNIV" by simp
from this[untransferred] show ?thesis.
qed
lemma vreal_one_closed: "1⇩ℝ ∈⇩∘ ℝ⇩∘"
proof-
have "(1::real) ∈ UNIV" by simp
from this[untransferred] show ?thesis.
qed
lemma vreal_plus_closed:
assumes "x ∈⇩∘ ℝ⇩∘" and "y ∈⇩∘ ℝ⇩∘"
shows "x +⇩ℝ y ∈⇩∘ ℝ⇩∘"
proof-
have "x' + y' ∈ UNIV" for x' y' :: real by simp
from this[untransferred, OF assms] show ?thesis.
qed
lemma vreal_uminus_closed:
assumes "x ∈⇩∘ ℝ⇩∘"
shows "-⇩ℝ x ∈⇩∘ ℝ⇩∘"
proof-
have "-x' ∈ UNIV" for x' :: real by simp
from this[untransferred, OF assms] show ?thesis.
qed
lemma vreal_mult_closed:
assumes "x ∈⇩∘ ℝ⇩∘" and "y ∈⇩∘ ℝ⇩∘"
shows "x *⇩ℝ y ∈⇩∘ ℝ⇩∘"
proof-
have "x' * y' ∈ UNIV" for x' y' :: real by simp
from this[untransferred, OF assms] show ?thesis.
qed
lemma vreal_inverse_closed:
assumes "x ∈⇩∘ ℝ⇩∘"
shows "x¯⇩ℝ ∈⇩∘ ℝ⇩∘"
proof-
have "inverse x' ∈ UNIV" for x' :: real by simp
from this[untransferred, OF assms] show ?thesis.
qed
text‹Associative Law for Addition: Definition 2.2.1.a.›
lemma vreal_assoc_law_addition:
assumes "x ∈⇩∘ ℝ⇩∘" and "y ∈⇩∘ ℝ⇩∘" and "z ∈⇩∘ ℝ⇩∘"
shows "(x +⇩ℝ y) +⇩ℝ z = x +⇩ℝ (y +⇩ℝ z)"
proof-
have "(x' + y') + z' = x' + (y' + z')" for x' y' z' :: real by simp
from this[untransferred, OF assms] show ?thesis.
qed
text‹Commutative Law for Addition: Definition 2.2.1.b.›
lemma vreal_commutative_law_addition:
assumes "x ∈⇩∘ ℝ⇩∘" and "y ∈⇩∘ ℝ⇩∘"
shows "x +⇩ℝ y = y +⇩ℝ x"
proof-
have "(x' + y') = y' + x' " for x' y' :: real by simp
from this[untransferred, OF assms] show ?thesis.
qed
text‹Identity Law for Addition: Definition 2.2.1.c.›
lemma vreal_identity_law_addition:
assumes "x ∈⇩∘ ℝ⇩∘"
shows "x +⇩ℝ 0⇩ℝ = x"
proof-
have "x' + 0 = x'" for x' :: real by simp
from this[untransferred, OF assms] show ?thesis.
qed
text‹Inverses Law for Addition: Definition 2.2.1.d.›
lemma vreal_inverses_law_addition:
assumes "x ∈⇩∘ ℝ⇩∘"
shows "x +⇩ℝ (-⇩ℝ x) = 0⇩ℝ"
proof-
have "x' + (-x') = 0" for x' :: real by simp
from this[untransferred, OF assms] show ?thesis.
qed
text‹Associative Law for Multiplication: Definition 2.2.1.e.›
lemma vreal_assoc_law_multiplication:
assumes "x ∈⇩∘ ℝ⇩∘" and "y ∈⇩∘ ℝ⇩∘" and "z ∈⇩∘ ℝ⇩∘"
shows "(x *⇩ℝ y) *⇩ℝ z = x *⇩ℝ (y *⇩ℝ z)"
proof-
have "(x' * y') * z' = x' * (y' * z')" for x' y' z' :: real by simp
from this[untransferred, OF assms] show ?thesis.
qed
text‹Commutative Law for Multiplication: Definition 2.2.1.f.›
lemma vreal_commutative_law_multiplication:
assumes "x ∈⇩∘ ℝ⇩∘" and "y ∈⇩∘ ℝ⇩∘"
shows "x *⇩ℝ y = y *⇩ℝ x"
proof-
have "(x' * y') = y' * x' " for x' y' :: real by simp
from this[untransferred, OF assms] show ?thesis.
qed
text‹Identity Law for Multiplication: Definition 2.2.1.g.›
lemma vreal_identity_law_multiplication:
assumes "x ∈⇩∘ ℝ⇩∘"
shows "x *⇩ℝ 1⇩ℝ = x"
proof-
have "x' * 1 = x'" for x' :: real by simp
from this[untransferred, OF assms] show ?thesis.
qed
text‹Inverses Law for Multiplication: Definition 2.2.1.h.›
lemma vreal_inverses_law_multiplication:
assumes "x ∈⇩∘ ℝ⇩∘" and "x ≠ 0⇩ℝ"
shows "x *⇩ℝ x¯⇩ℝ = 1⇩ℝ"
proof-
have "x' ≠ 0 ⟹ x' * inverse x' = 1" for x' :: real by simp
from this[untransferred, OF assms] show ?thesis.
qed
text‹Distributive Law: Definition 2.2.1.i.›
lemma vreal_distributive_law:
assumes "x ∈⇩∘ ℝ⇩∘" and "y ∈⇩∘ ℝ⇩∘" and "z ∈⇩∘ ℝ⇩∘"
shows "x *⇩ℝ (y +⇩ℝ z) = x *⇩ℝ y +⇩ℝ x *⇩ℝ z"
proof-
have "x' * (y' + z') = (x' * y') + (x' * z')" for x' y' z' :: real
by (simp add: field_simps)
from this[untransferred, OF assms] show ?thesis.
qed
text‹Trichotomy Law: Definition 2.2.1.j.›
lemma vreal_trichotomy_law:
assumes "x ∈⇩∘ ℝ⇩∘" "y ∈⇩∘ ℝ⇩∘"
shows
"(x <⇩ℝ y ∧ ~(x = y) ∧ ~(y <⇩ℝ x)) ∨
(~(x <⇩ℝ y) ∧ x = y ∧ ~(y <⇩ℝ x)) ∨
(~(x <⇩ℝ y) ∧ ~(x = y) ∧ y <⇩ℝ x)"
proof-
have "(x' < y' ∧ ~(x' = y') ∧ ~(y' < x')) ∨
(~(x' < y') ∧ x' = y' ∧ ~(y' < x')) ∨
(~(x' < y') ∧ ~(x' = y') ∧ y' < x')"
for x' y' z' :: real
by auto
from this[untransferred, OF assms] show ?thesis.
qed
text‹Transitive Law: Definition 2.2.1.k.›
lemma vreal_transitive_law:
assumes "x ∈⇩∘ ℝ⇩∘"
and "y ∈⇩∘ ℝ⇩∘"
and "z ∈⇩∘ ℝ⇩∘"
and "x <⇩ℝ y" and "y <⇩ℝ z"
shows "x <⇩ℝ z"
proof-
have "x' < y' ⟹ y' < z' ⟹ x' < z'" for x' y' z' :: real by simp
from this[untransferred, OF assms] show ?thesis.
qed
text‹Addition Law of Order: Definition 2.2.1.l.›
lemma vreal_addition_law_of_order:
assumes "x ∈⇩∘ ℝ⇩∘" and "y ∈⇩∘ ℝ⇩∘" and "z ∈⇩∘ ℝ⇩∘" and "x <⇩ℝ y"
shows "x +⇩ℝ z <⇩ℝ y +⇩ℝ z"
proof-
have "x' < y' ⟹ x' + z' < y' + z'" for x' y' z' :: real by simp
from this[untransferred, OF assms] show ?thesis.
qed
text‹Multiplication Law of Order: Definition 2.2.1.m.›
lemma vreal_multiplication_law_of_order:
assumes "x ∈⇩∘ ℝ⇩∘"
and "y ∈⇩∘ ℝ⇩∘"
and "z ∈⇩∘ ℝ⇩∘"
and "x <⇩ℝ y"
and "0⇩ℝ <⇩ℝ z"
shows "x *⇩ℝ z <⇩ℝ y *⇩ℝ z"
proof-
have "x' < y' ⟹ 0 < z' ⟹ x' * z' < y' * z'" for x' y' z' :: real by simp
from this[untransferred, OF assms] show ?thesis.
qed
text‹Non-Triviality: Definition 2.2.1.n.›
lemma vreal_non_triviality: "0⇩ℝ ≠ 1⇩ℝ"
proof-
have "0 ≠ (1::real)" by simp
from this[untransferred] show ?thesis.
qed
text‹Least upper bound property: Definition 2.2.3.›
lemma least_upper_bound_property:
defines "vreal_ub S M ≡ (S ⊆⇩∘ ℝ⇩∘ ∧ M ∈⇩∘ ℝ⇩∘ ∧ (∀x∈⇩∘S. x ≤⇩ℝ M))"
assumes "A ⊆⇩∘ ℝ⇩∘" and "A ≠ 0" and "∃M. vreal_ub A M"
obtains M where "vreal_ub A M" and "⋀T. vreal_ub A T ⟹ M ≤⇩ℝ T"
proof-
note complete_real =
complete_real[
untransferred, of ‹elts A›, unfolded vnumber_simps, OF assms(2)
]
from assms obtain x where "x ∈⇩∘ A" by force
moreover with assms have "x ∈⇩∘ ℝ⇩∘" by auto
ultimately have 1: "∃x∈⇩∘ℝ⇩∘. x ∈⇩∘ A" by auto
from assms have 2: "∃x∈⇩∘ℝ⇩∘. ∀y∈⇩∘A. y ≤⇩ℝ x" by auto
from complete_real[OF 1 2]
obtain M
where "M ∈⇩∘ ℝ⇩∘"
and "⋀x. x ∈⇩∘ A ⟹ x ≤⇩ℝ M"
and [simp]: "⋀T. T ∈⇩∘ ℝ⇩∘ ⟹ (⋀x. x ∈⇩∘ A ⟹ x ≤⇩ℝ T) ⟹ M ≤⇩ℝ T"
by force
with assms(2) have "vreal_ub A M" unfolding vreal_ub_def by simp
moreover have "vreal_ub A T ⟹ M ≤⇩ℝ T" for T unfolding vreal_ub_def by simp
ultimately show ?thesis using that by auto
qed
subsubsection‹Fundamental properties of other operations›
text‹Minus.›
lemma vreal_minus_closed:
assumes "x ∈⇩∘ ℝ⇩∘" and "y ∈⇩∘ ℝ⇩∘"
shows "x -⇩ℝ y ∈⇩∘ ℝ⇩∘"
proof-
have "x' - y' ∈ UNIV" for x' y' :: real by simp
from this[untransferred, OF assms] show ?thesis.
qed
lemma vreal_minus_eq_plus_uminus:
assumes "x ∈⇩∘ ℝ⇩∘" and "y ∈⇩∘ ℝ⇩∘"
shows "x -⇩ℝ y = x +⇩ℝ (-⇩ℝ y)"
proof-
have "x' - y' = x' + (-y')" for x' y' :: real by simp
from this[untransferred, OF assms] show ?thesis.
qed
text‹Unary minus.›
lemma vreal_uminus_uminus:
assumes "x ∈⇩∘ ℝ⇩∘"
shows "x = -⇩ℝ (-⇩ℝ x)"
proof-
have "x' = -(-x')" for x' :: real by simp
from this[untransferred, OF assms] show ?thesis.
qed
text‹Multiplicative inverse.›
lemma vreal_inverse_inverse:
assumes "x ∈⇩∘ ℝ⇩∘"
shows "x = (x¯⇩ℝ)¯⇩ℝ"
proof-
have "x' = inverse (inverse x')" for x' :: real by simp
from this[untransferred, OF assms] show ?thesis.
qed
subsubsection‹Further properties›
text‹Addition.›
global_interpretation vreal_plus: binop_onto ‹ℝ⇩∘› vreal_plus
proof-
have binop: "binop ℝ⇩∘ vreal_plus"
proof(intro binopI nopI)
show vsv: "vsv vreal_plus" unfolding vreal_plus_def by auto
interpret vsv vreal_plus by (rule vsv)
show "2⇩ℕ ∈⇩∘ ω" by simp
show dom: "𝒟⇩∘ vreal_plus = ℝ⇩∘ ^⇩× 2⇩ℕ" unfolding vreal_plus_def by simp
show "ℛ⇩∘ vreal_plus ⊆⇩∘ ℝ⇩∘"
proof(intro vsubsetI)
fix y assume "y ∈⇩∘ ℛ⇩∘ vreal_plus"
then obtain ab where "ab ∈⇩∘ ℝ⇩∘ ^⇩× 2⇩ℕ" and y_def: "y = vreal_plus⦇ab⦈"
unfolding dom[symmetric] by force
then obtain a b
where ab_def: "ab = [a, b]⇩∘" and a: "a ∈⇩∘ ℝ⇩∘" and b: "b ∈⇩∘ ℝ⇩∘"
by blast
then show "y ∈⇩∘ ℝ⇩∘" by (simp add: vreal_plus_closed y_def)
qed
qed
interpret binop ‹ℝ⇩∘› vreal_plus by (rule binop)
show "binop_onto ℝ⇩∘ vreal_plus"
proof(intro binop_ontoI')
show "binop ℝ⇩∘ vreal_plus" by (rule binop_axioms)
show "ℝ⇩∘ ⊆⇩∘ ℛ⇩∘ vreal_plus"
proof(intro vsubsetI)
fix y assume prems: "y ∈⇩∘ ℝ⇩∘"
moreover from vreal_zero vreal_zero_closed have "0 ∈⇩∘ ℝ⇩∘" by auto
ultimately have "y +⇩ℝ 0 ∈⇩∘ ℛ⇩∘ vreal_plus" by auto
moreover from prems vreal_identity_law_addition have "y = y +⇩ℝ 0"
by (simp add: vreal_zero)
ultimately show "y ∈⇩∘ ℛ⇩∘ vreal_plus" by simp
qed
qed
qed
text‹Unary minus.›
global_interpretation vreal_uminus: v11 vreal_uminus
rewrites "𝒟⇩∘ vreal_uminus = ℝ⇩∘"
and "ℛ⇩∘ vreal_uminus = ℝ⇩∘"
proof-
show v11: "v11 vreal_uminus"
proof(intro v11I)
show vsv: "vsv vreal_uminus" unfolding vreal_uminus_def by simp
interpret vsv vreal_uminus by (rule vsv)
show "vsv (vreal_uminus¯⇩∘)"
proof(intro vsvI)
show "vbrelation (vreal_uminus¯⇩∘)" by clarsimp
fix a b c
assume prems: "⟨a, b⟩ ∈⇩∘ vreal_uminus¯⇩∘" "⟨a, c⟩ ∈⇩∘ vreal_uminus¯⇩∘"
then have ba: "⟨b, a⟩ ∈⇩∘ vreal_uminus" and ca: "⟨c, a⟩ ∈⇩∘ vreal_uminus"
by auto
then have b: "b ∈⇩∘ ℝ⇩∘" and c: "c ∈⇩∘ ℝ⇩∘"
by (simp_all add: VLambda_iff2 vreal_uminus_def)
from ba ca have "a = -⇩ℝ b" "a = -⇩ℝ c" by simp_all
with ba ca b c show "b = c" by (metis vreal_uminus_uminus)
qed
qed
interpret v11 vreal_uminus by (rule v11)
show dom: "𝒟⇩∘ vreal_uminus = ℝ⇩∘" unfolding vreal_uminus_def by simp
have "ℛ⇩∘ vreal_uminus ⊆⇩∘ ℝ⇩∘"
proof(intro vsubsetI)
fix y assume "y ∈⇩∘ ℛ⇩∘ vreal_uminus"
then obtain x where "x ∈⇩∘ ℝ⇩∘" and y_def: "y = -⇩ℝ x"
unfolding dom[symmetric] by force
then show "y ∈⇩∘ ℝ⇩∘" by (simp add: vreal_uminus_closed)
qed
moreover have "ℝ⇩∘ ⊆⇩∘ ℛ⇩∘ vreal_uminus"
by (intro vsubsetI)
(metis dom vdomain_atD vreal_uminus_closed vreal_uminus_uminus)
ultimately show "ℛ⇩∘ vreal_uminus = ℝ⇩∘" by simp
qed
text‹Multiplication.›
global_interpretation vreal_mult: binop_onto ‹ℝ⇩∘› vreal_mult
proof-
have binop: "binop ℝ⇩∘ vreal_mult"
proof(intro binopI nopI)
show vsv: "vsv vreal_mult" unfolding vreal_mult_def by auto
interpret vsv vreal_mult by (rule vsv)
show "2⇩ℕ ∈⇩∘ ω" by simp
show dom: "𝒟⇩∘ vreal_mult = ℝ⇩∘ ^⇩× 2⇩ℕ" unfolding vreal_mult_def by simp
show "ℛ⇩∘ vreal_mult ⊆⇩∘ ℝ⇩∘"
proof(intro vsubsetI)
fix y assume "y ∈⇩∘ ℛ⇩∘ vreal_mult"
then obtain ab where "ab ∈⇩∘ ℝ⇩∘ ^⇩× 2⇩ℕ" and y_def: "y = vreal_mult⦇ab⦈"
unfolding dom[symmetric] by force
then obtain a b
where ab_def: "ab = [a, b]⇩∘" and a: "a ∈⇩∘ ℝ⇩∘" and b: "b ∈⇩∘ ℝ⇩∘"
by blast
then show "y ∈⇩∘ ℝ⇩∘" by (simp add: vreal_mult_closed y_def)
qed
qed
interpret binop ‹ℝ⇩∘› vreal_mult by (rule binop)
show "binop_onto ℝ⇩∘ vreal_mult"
proof(intro binop_ontoI')
show "binop ℝ⇩∘ vreal_mult" by (rule binop_axioms)
show "ℝ⇩∘ ⊆⇩∘ ℛ⇩∘ vreal_mult"
proof(intro vsubsetI)
fix y assume prems: "y ∈⇩∘ ℝ⇩∘"
moreover from vreal_one vreal_one_closed have "1 ∈⇩∘ ℝ⇩∘" by auto
ultimately have "y *⇩ℝ 1 ∈⇩∘ ℛ⇩∘ vreal_mult" by auto
moreover from prems vreal_identity_law_multiplication have "y = y *⇩ℝ 1"
by (simp add: vreal_one)
ultimately show "y ∈⇩∘ ℛ⇩∘ vreal_mult" by simp
qed
qed
qed
text‹Multiplicative inverse.›
global_interpretation vreal_inverse: v11 vreal_inverse
rewrites "𝒟⇩∘ vreal_inverse = ℝ⇩∘"
and "ℛ⇩∘ vreal_inverse = ℝ⇩∘"
proof-
show v11: "v11 vreal_inverse"
proof(intro v11I)
show vsv: "vsv vreal_inverse" unfolding vreal_inverse_def by simp
interpret vsv vreal_inverse by (rule vsv)
show "vsv (vreal_inverse¯⇩∘)"
proof(intro vsvI)
show "vbrelation (vreal_inverse¯⇩∘)" by clarsimp
fix a b c
assume prems: "⟨a, b⟩ ∈⇩∘ vreal_inverse¯⇩∘" "⟨a, c⟩ ∈⇩∘ vreal_inverse¯⇩∘"
then have ba: "⟨b, a⟩ ∈⇩∘ vreal_inverse" and ca: "⟨c, a⟩ ∈⇩∘ vreal_inverse"
by auto
then have b: "b ∈⇩∘ ℝ⇩∘" and c: "c ∈⇩∘ ℝ⇩∘"
by (simp_all add: VLambda_iff2 vreal_inverse_def)
from ba ca have "a = b¯⇩ℝ" "a = c¯⇩ℝ" by simp_all
with ba ca b c show "b = c" by (metis vreal_inverse_inverse)
qed
qed
interpret v11 vreal_inverse by (rule v11)
show dom: "𝒟⇩∘ vreal_inverse = ℝ⇩∘" unfolding vreal_inverse_def by simp
have "ℛ⇩∘ vreal_inverse ⊆⇩∘ ℝ⇩∘"
proof(intro vsubsetI)
fix y assume "y ∈⇩∘ ℛ⇩∘ vreal_inverse"
then obtain x where "x ∈⇩∘ ℝ⇩∘" and y_def: "y = x¯⇩ℝ"
unfolding dom[symmetric] by force
then show "y ∈⇩∘ ℝ⇩∘" by (simp add: vreal_inverse_closed)
qed
moreover have "ℝ⇩∘ ⊆⇩∘ ℛ⇩∘ vreal_inverse"
by (intro vsubsetI)
(metis dom vdomain_atD vreal_inverse_closed vreal_inverse_inverse)
ultimately show "ℛ⇩∘ vreal_inverse = ℝ⇩∘" by simp
qed
subsection‹Integer numbers›
subsubsection‹Definition›
definition vint_of_int :: "int ⇒ V"
where "vint_of_int = vreal_of_real"
notation vint_of_int (‹_⇩ℤ› [999] 999)
declare [[coercion "vint_of_int :: int ⇒ V"]]
definition vint :: V (‹ℤ⇩∘›)
where "vint = set (range vint_of_int)"
definition int_of_vint :: "V ⇒ int"
where "int_of_vint = inv_into UNIV vint_of_int"
text‹Rules.›
lemma vint_of_int_in_vintI[intro, simp]: "a⇩ℤ ∈⇩∘ ℤ⇩∘" by (simp add: vint_def)
lemma vint_of_int_in_vintE[elim]:
assumes "a ∈⇩∘ ℤ⇩∘"
obtains b where "b⇩ℤ = a"
using assms unfolding vint_def by auto
subsubsection‹Elementary properties›
lemma vint_vsubset_vreal: "ℤ⇩∘ ⊆⇩∘ ℝ⇩∘"
unfolding vint_def vint_of_int_def vreal_def using image_cong by auto
lemma inj_vint_of_int: "inj vint_of_int"
using inj_vreal_of_real
unfolding vint_of_int_def inj_def of_int_eq_iff
by force
lemma vint_in_Vset_ω2: "ℤ⇩∘ ∈⇩∘ Vset (ω + ω)"
using vint_vsubset_vreal vreal_in_Vset_ω2 by auto
lemma int_of_vint_vint_of_int[simp]: "int_of_vint (a⇩ℤ) = a"
by (simp add: inj_vint_of_int int_of_vint_def)
text‹Transfer rules.›
definition cr_vint :: "V ⇒ int ⇒ bool"
where "cr_vint a b ⟷ (a = vint_of_int b)"
lemma cr_vint_right_total[transfer_rule]: "right_total cr_vint"
unfolding cr_vint_def right_total_def by simp
lemma cr_vint_bi_unqie[transfer_rule]: "bi_unique cr_vint"
unfolding cr_vint_def bi_unique_def
by (simp add: inj_eq inj_vint_of_int)
lemma cr_vint_transfer_domain_rule[transfer_domain_rule]:
"Domainp cr_vint = (λx. x ∈⇩∘ ℤ⇩∘)"
unfolding cr_vint_def by force
lemma vint_transfer[transfer_rule]:
"(rel_set cr_vint) (elts ℤ⇩∘) (UNIV::int set)"
unfolding cr_vint_def rel_set_def by auto
lemma vint_of_int_transfer[transfer_rule]: "cr_vint (vint_of_int a) a"
unfolding cr_vint_def by auto
subsubsection‹Constants and operations›
text‹Auxiliary.›
lemma vint_fsingleton_in_fproduct_vint: "[a⇩ℤ]⇩∘ ∈⇩∘ ℤ⇩∘ ^⇩× 1⇩ℕ" by auto
lemma vint_fpair_in_fproduct_vint: "[a⇩ℤ, b⇩ℤ]⇩∘ ∈⇩∘ ℤ⇩∘ ^⇩× 2⇩ℕ" by force
text‹Zero.›
lemma vint_zero: "0⇩ℤ = (0::V)" by (simp add: vint_of_int_def vreal_zero)
text‹One.›
lemma vint_one: "1⇩ℤ = (1::V)" by (simp add: vreal_one vint_of_int_def)
text‹Addition.›
definition vint_plus :: V
where "vint_plus =
(λx∈⇩∘ℤ⇩∘ ^⇩× 2⇩ℕ. (int_of_vint (x⦇0⇩ℕ⦈) + int_of_vint (x⦇1⇩ℕ⦈))⇩ℤ)"
abbreviation vint_plus_app (infixl "+⇩ℤ" 65)
where "vint_plus_app a b ≡ vint_plus⦇a, b⦈⇩∙"
lemma vint_plus_transfer[transfer_rule]:
includes lifting_syntax
shows "(cr_vint ===> cr_vint ===> cr_vint) (+⇩ℤ) (+)"
using vint_fpair_in_fproduct_vint
by (intro rel_funI, unfold vint_plus_def cr_vint_def cr_scalar_def)
(simp add: nat_omega_simps)
text‹Multiplication.›
definition vint_mult :: V
where "vint_mult =
(λx∈⇩∘ℤ⇩∘ ^⇩× 2⇩ℕ. (int_of_vint (x⦇0⇩ℕ⦈) * int_of_vint (x⦇1⇩ℕ⦈))⇩ℤ)"
abbreviation vint_mult_app (infixl "*⇩ℤ" 65)
where "vint_mult_app a b ≡ vint_mult⦇a, b⦈⇩∙"
lemma vint_mult_transfer[transfer_rule]:
includes lifting_syntax
shows "(cr_vint ===> cr_vint ===> cr_vint) (*⇩ℤ) (*)"
using vint_fpair_in_fproduct_vint
by (intro rel_funI, unfold vint_mult_def cr_vint_def cr_scalar_def)
(simp add: nat_omega_simps)
text‹Unary minus.›
definition vint_uminus :: V
where "vint_uminus = (λx∈⇩∘ℤ⇩∘. (uminus (int_of_vint x))⇩ℤ)"
abbreviation vint_uminus_app ("-⇩ℤ _" [81] 80)
where "-⇩ℤ a ≡ vint_uminus⦇a⦈"
lemma vint_uminus_transfer[transfer_rule]:
includes lifting_syntax
shows "(cr_vint ===> cr_vint) (vint_uminus_app) (uminus)"
using vint_fsingleton_in_fproduct_vint
by (intro rel_funI, unfold vint_uminus_def cr_vint_def cr_scalar_def)
(simp add: nat_omega_simps)
text‹Order.›
definition vint_le :: V
where "vint_le =
set {[a, b]⇩∘ | a b. [a, b]⇩∘ ∈⇩∘ ℤ⇩∘ ^⇩× 2⇩ℕ ∧ int_of_vint a ≤ int_of_vint b}"
abbreviation vint_le' ("(_/ ≤⇩ℤ _)" [51, 51] 50)
where "a ≤⇩ℤ b ≡ [a, b]⇩∘ ∈⇩∘ vint_le"
lemma small_vint_le[simp]:
"small {[a, b]⇩∘ | a b. [a, b]⇩∘ ∈⇩∘ ℤ⇩∘ ^⇩× 2⇩ℕ ∧ int_of_vint a ≤ int_of_vint b}"
proof-
have small: "small {[a, b]⇩∘ | a b. [a, b]⇩∘ ∈⇩∘ ℤ⇩∘ ^⇩× 2⇩ℕ}" by simp
show ?thesis by (rule smaller_than_small[OF small]) auto
qed
lemma vint_le_transfer[transfer_rule]:
includes lifting_syntax
shows "(cr_vint ===> cr_vint ===> (=)) vint_le' (≤)"
using vint_fsingleton_in_fproduct_vint
by (intro rel_funI, unfold cr_scalar_def cr_vint_def vint_le_def)
(auto simp: nat_omega_simps)
text‹Strict order.›
definition vint_ls :: V
where "vint_ls =
set {[a, b]⇩∘ | a b. [a, b]⇩∘ ∈⇩∘ ℤ⇩∘ ^⇩× 2⇩ℕ ∧ int_of_vint a < int_of_vint b}"
abbreviation vint_ls' ("(_/ <⇩ℤ _)" [51, 51] 50)
where "a <⇩ℤ b ≡ [a, b]⇩∘ ∈⇩∘ vint_ls"
lemma small_vint_ls[simp]:
"small {[a, b]⇩∘ | a b. [a, b]⇩∘ ∈⇩∘ ℤ⇩∘ ^⇩× 2⇩ℕ ∧ int_of_vint a < int_of_vint b}"
proof-
have small: "small {[a, b]⇩∘ | a b. [a, b]⇩∘ ∈⇩∘ ℤ⇩∘ ^⇩× 2⇩ℕ}" by simp
show ?thesis by (rule smaller_than_small[OF small]) auto
qed
lemma vint_ls_transfer[transfer_rule]:
includes lifting_syntax
shows "(cr_vint ===> cr_vint ===> (=)) vint_ls' (<)"
using vint_fsingleton_in_fproduct_vint
by (intro rel_funI, unfold cr_scalar_def cr_vint_def vint_ls_def)
(auto simp: nat_omega_simps)
text‹Subtraction.›
definition vint_minus :: V
where "vint_minus =
(λx∈⇩∘ℤ⇩∘ ^⇩× 2⇩ℕ. (int_of_vint (x⦇0⇩ℕ⦈) - int_of_vint (x⦇1⇩ℕ⦈))⇩ℤ)"
abbreviation vint_minus_app (infixl "-⇩ℤ" 65)
where "vint_minus_app a b ≡ vint_minus⦇a, b⦈⇩∙"
lemma vint_minus_transfer[transfer_rule]:
includes lifting_syntax
shows "(cr_vint ===> cr_vint ===> cr_vint)
(-⇩ℤ) (-)"
using vint_fpair_in_fproduct_vint
by (intro rel_funI, unfold vint_minus_def cr_vint_def cr_scalar_def)
(simp add: nat_omega_simps)
subsubsection‹Axioms of a well ordered integral domain›
text‹The exposition follows Definition 1.4.1 from the textbook
‹The Real Numbers and Real Analysis› by E. Bloch
\cite{bloch_real_2010}.›
lemma vint_zero_closed: "0⇩ℤ ∈⇩∘ ℤ⇩∘" by auto
lemma vint_one_closed: "1⇩ℤ ∈⇩∘ ℤ⇩∘" by auto
lemma vint_plus_closed:
assumes "x ∈⇩∘ ℤ⇩∘" and "y ∈⇩∘ ℤ⇩∘"
shows "x +⇩ℤ y ∈⇩∘ ℤ⇩∘"
proof-
have "x' + y' ∈ UNIV" for x' y' :: int by simp
from this[untransferred, OF assms] show ?thesis.
qed
lemma vint_mult_closed:
assumes "x ∈⇩∘ ℤ⇩∘" and "y ∈⇩∘ ℤ⇩∘"
shows "x *⇩ℤ y ∈⇩∘ ℤ⇩∘"
proof-
have "(x'::int) * y' ∈ UNIV" for x' y' by simp
from this[untransferred, OF assms] show ?thesis.
qed
lemma vint_uminus_closed:
assumes "x ∈⇩∘ ℤ⇩∘"
shows "-⇩ℤ x ∈⇩∘ ℤ⇩∘"
proof-
have "(-x'::int) ∈ UNIV" for x' by simp
from this[untransferred, OF assms] show ?thesis.
qed
text‹Associative Law for Addition: Definition 1.4.1.a.›
lemma vint_assoc_law_addition:
assumes "x ∈⇩∘ ℤ⇩∘" and "y ∈⇩∘ ℤ⇩∘" and "z ∈⇩∘ ℤ⇩∘"
shows "(x +⇩ℤ y) +⇩ℤ z = x +⇩ℤ (y +⇩ℤ z)"
proof-
have "(x' + y') + z' = x' + (y' + z')" for x' y' z' :: int by simp
from this[untransferred, OF assms] show ?thesis.
qed
text‹Commutative Law for Addition: Definition 1.4.1.b.›
lemma vint_commutative_law_addition:
assumes "x ∈⇩∘ ℤ⇩∘" and "y ∈⇩∘ ℤ⇩∘"
shows "x +⇩ℤ y = y +⇩ℤ x"
proof-
have "x' + y' = y' + x'" for x' y' :: int by simp
from this[untransferred, OF assms] show ?thesis.
qed
text‹Identity Law for Addition: Definition 1.4.1.c.›
lemma vint_identity_law_addition:
assumes [simp]: "x ∈⇩∘ ℤ⇩∘"
shows "x +⇩ℤ 0⇩ℤ = x"
proof-
have "x' + 0 = x'" for x' :: int by simp
from this[untransferred, OF assms] show ?thesis.
qed
text‹Inverses Law for Addition: Definition 1.4.1.d.›
lemma vint_inverses_law_addition:
assumes [simp]: "x ∈⇩∘ ℤ⇩∘"
shows "x +⇩ℤ (-⇩ℤ x) = 0⇩ℤ"
proof-
have "x' + (-x') = 0" for x' :: int by simp
from this[untransferred, OF assms] show ?thesis.
qed
text‹Associative Law for Multiplication: Definition 1.4.1.e.›
lemma vint_assoc_law_multiplication:
assumes "x ∈⇩∘ ℤ⇩∘" and "y ∈⇩∘ ℤ⇩∘" and "z ∈⇩∘ ℤ⇩∘"
shows "(x *⇩ℤ y) *⇩ℤ z = x *⇩ℤ (y *⇩ℤ z)"
proof-
have "(x' * y') * z' = x' * (y' * z')" for x' y' z' :: int by simp
from this[untransferred, OF assms] show ?thesis.
qed
text‹Commutative Law for Multiplication: Definition 1.4.1.f.›
lemma vint_commutative_law_multiplication:
assumes "x ∈⇩∘ ℤ⇩∘" and "y ∈⇩∘ ℤ⇩∘"
shows "x *⇩ℤ y = y *⇩ℤ x"
proof-
have "x' * y' = y' * x'" for x' y' :: int by simp
from this[untransferred, OF assms] show ?thesis.
qed
text‹Identity Law for multiplication: Definition 1.4.1.g.›
lemma vint_identity_law_multiplication:
assumes "x ∈⇩∘ ℤ⇩∘"
shows "x *⇩ℤ 1⇩ℤ = x"
proof-
have "x' * 1 = x'" for x' :: int by simp
from this[untransferred, OF assms] show ?thesis.
qed
text‹Distributive Law for Multiplication: Definition 1.4.1.h.›
lemma vint_distributive_law:
assumes "x ∈⇩∘ ℤ⇩∘" and "y ∈⇩∘ ℤ⇩∘" and "z ∈⇩∘ ℤ⇩∘"
shows "x *⇩ℤ (y +⇩ℤ z) = (x *⇩ℤ y) +⇩ℤ (x *⇩ℤ z)"
proof-
have "x' * (y' + z') = (x' * y') + (x' * z')" for x' y' z' :: int
by (simp add: algebra_simps)
from this[untransferred, OF assms] show ?thesis.
qed
text‹No Zero Divisors Law: Definition 1.4.1.i.›
lemma vint_no_zero_divisors_law:
assumes "x ∈⇩∘ ℤ⇩∘" and "y ∈⇩∘ ℤ⇩∘" and "x *⇩ℤ y = 0⇩ℤ"
shows "x = 0⇩ℤ ∨ y = 0⇩ℤ"
proof-
have "x' * y' = 0 ⟹ x' = 0 ∨ y' = 0" for x' y' z' :: int
by (simp add: algebra_simps)
from this[untransferred, OF assms] show ?thesis.
qed
text‹Trichotomy Law: Definition 1.4.1.j›
lemma vint_trichotomy_law:
assumes "x ∈⇩∘ ℤ⇩∘" and "y ∈⇩∘ ℤ⇩∘"
shows
"(x <⇩ℤ y ∧ ~(x = y) ∧ ~(y <⇩ℤ x)) ∨
(~(x <⇩ℤ y) ∧ x = y ∧ ~(y <⇩ℤ x)) ∨
(~(x <⇩ℤ y) ∧ ~(x = y) ∧ y <⇩ℤ x)"
proof-
have
"(x' < y' ∧ ~(x' = y') ∧ ~(y' < x')) ∨
(~(x' < y') ∧ x' = y' ∧ ~(y' < x')) ∨
(~(x' < y') ∧ ~(x' = y') ∧ y' < x')"
for x' y' z' :: int
by auto
from this[untransferred, OF assms] show ?thesis.
qed
text‹Transitive Law: Definition 1.4.1.k›
lemma vint_transitive_law:
assumes "x ∈⇩∘ ℤ⇩∘"
and "y ∈⇩∘ ℤ⇩∘"
and "z ∈⇩∘ ℤ⇩∘"
and "x <⇩ℤ y"
and "y <⇩ℤ z"
shows "x <⇩ℤ z"
proof-
have "x' < y' ⟹ y' < z' ⟹ x' < z'" for x' y' z' :: int by simp
from this[untransferred, OF assms] show ?thesis.
qed
text‹Addition Law of Order: Definition 1.4.1.l›
lemma vint_addition_law_of_order:
assumes "x ∈⇩∘ ℤ⇩∘" and "y ∈⇩∘ ℤ⇩∘" and "z ∈⇩∘ ℤ⇩∘" and "x <⇩ℤ y"
shows "x +⇩ℤ z <⇩ℤ y +⇩ℤ z"
proof-
have "x' < y' ⟹ x' + z' < y' + z'" for x' y' z' :: int by simp
from this[untransferred, OF assms] show ?thesis.
qed
text‹Multiplication Law of Order: Definition 1.4.1.m›
lemma vint_multiplication_law_of_order:
assumes "x ∈⇩∘ ℤ⇩∘"
and "y ∈⇩∘ ℤ⇩∘"
and "z ∈⇩∘ ℤ⇩∘"
and "x <⇩ℤ y"
and "0⇩ℤ <⇩ℤ z"
shows "x *⇩ℤ z <⇩ℤ y *⇩ℤ z"
proof-
have "x' < y' ⟹ 0 < z' ⟹ x' * z' < y' * z'" for x' y' z' :: int by simp
from this[untransferred, OF assms] show ?thesis.
qed
text‹Non-Triviality: Definition 1.4.1.n›
lemma vint_non_triviality: "0⇩ℤ ≠ 1⇩ℤ"
proof-
have "0 ≠ (1::int)" by simp
from this[untransferred] show ?thesis.
qed
text‹Well-Ordering Principle.›
lemma well_ordering_principle:
assumes "A ⊆⇩∘ ℤ⇩∘"
and "a ∈⇩∘ ℤ⇩∘"
and "A ≠ 0"
and "⋀x. x ∈⇩∘ A ⟹ a <⇩ℤ x"
obtains b where "b ∈⇩∘ A" and "⋀x. x ∈⇩∘ A ⟹ b ≤⇩ℤ x"
proof-
{
fix A' and a' :: int assume prems: "A' ≠ {}" "x ∈ A' ⟹ a' < x" for x
then obtain a'' where a'': "a'' ∈ A'" by auto
from wfE_min[OF wf_int_ge_less_than[of a'], OF a''] obtain b'
where b'_A': "b' ∈ A'"
and yb': "(y, b') ∈ int_ge_less_than a' ⟹ y ∉ A'"
for y
by auto
moreover from prems b'_A' yb' have "⋀x. x ∈ A' ⟹ b' ≤ x"
unfolding int_ge_less_than_def by fastforce
with b'_A' have "∃b. b ∈ A' ∧ (∀x. x ∈ A' ⟶ b ≤ x)" by blast
}
note real_wo = this
from real_wo[
untransferred, of ‹elts A›, unfolded vnumber_simps, OF assms(1,2)
]
obtain b
where "b ∈⇩∘ ℤ⇩∘"
and "b ∈⇩∘ A"
and "⋀x. x ∈⇩∘ ℤ⇩∘ ⟹ x ∈⇩∘ A ⟹ b ≤⇩ℤ x"
by (auto simp: assms(3,4))
with assms that show ?thesis unfolding vsubset_iff by simp
qed
subsubsection‹Fundamental properties of other operations›
text‹Minus.›
lemma vint_minus_closed:
assumes "x ∈⇩∘ ℤ⇩∘" and "y ∈⇩∘ ℤ⇩∘"
shows "x -⇩ℤ y ∈⇩∘ ℤ⇩∘"
proof-
have "x' - y' ∈ UNIV" for x' y' :: int by simp
from this[untransferred, OF assms] show ?thesis.
qed
lemma vint_minus_eq_plus_uminus:
assumes "x ∈⇩∘ ℤ⇩∘" and "y ∈⇩∘ ℤ⇩∘"
shows "x -⇩ℤ y = x +⇩ℤ (-⇩ℤ y)"
proof-
have "x' - y' = x' + (-y')" for x' y' :: int by simp
from this[untransferred, OF assms] show ?thesis.
qed
text‹Unary minus.›
lemma vint_uminus_uminus:
assumes "x ∈⇩∘ ℤ⇩∘"
shows "x = -⇩ℤ (-⇩ℤ x)"
proof-
have "x' = -(-x')" for x' :: int by simp
from this[untransferred, OF assms] show ?thesis.
qed
subsubsection‹Further properties›
text‹Addition.›
global_interpretation vint_plus: binop_onto ‹ℤ⇩∘› vint_plus
proof-
have binop: "binop ℤ⇩∘ vint_plus"
proof(intro binopI nopI)
show vsv: "vsv vint_plus" unfolding vint_plus_def by auto
interpret vsv vint_plus by (rule vsv)
show "2⇩ℕ ∈⇩∘ ω" by simp
show dom: "𝒟⇩∘ vint_plus = ℤ⇩∘ ^⇩× 2⇩ℕ" unfolding vint_plus_def by simp
show "ℛ⇩∘ vint_plus ⊆⇩∘ ℤ⇩∘"
proof(intro vsubsetI)
fix y assume "y ∈⇩∘ ℛ⇩∘ vint_plus"
then obtain ab where "ab ∈⇩∘ ℤ⇩∘ ^⇩× 2⇩ℕ" and y_def: "y = vint_plus⦇ab⦈"
unfolding dom[symmetric] by force
then obtain a b
where ab_def: "ab = [a, b]⇩∘" and a: "a ∈⇩∘ ℤ⇩∘" and b: "b ∈⇩∘ ℤ⇩∘"
by blast
then show "y ∈⇩∘ ℤ⇩∘" by (simp add: vint_plus_closed y_def)
qed
qed
interpret binop ‹ℤ⇩∘› vint_plus by (rule binop)
show "binop_onto ℤ⇩∘ vint_plus"
proof(intro binop_ontoI')
show "binop ℤ⇩∘ vint_plus" by (rule binop_axioms)
show "ℤ⇩∘ ⊆⇩∘ ℛ⇩∘ vint_plus"
proof(intro vsubsetI)
fix y assume prems: "y ∈⇩∘ ℤ⇩∘"
moreover from vint_zero vint_zero_closed have "0 ∈⇩∘ ℤ⇩∘" by auto
ultimately have "y +⇩ℤ 0 ∈⇩∘ ℛ⇩∘ vint_plus" by auto
moreover from prems vint_identity_law_addition have "y = y +⇩ℤ 0"
by (simp add: vint_zero)
ultimately show "y ∈⇩∘ ℛ⇩∘ vint_plus" by simp
qed
qed
qed
text‹Unary minus.›
global_interpretation vint_uminus: v11 vint_uminus
rewrites "𝒟⇩∘ vint_uminus = ℤ⇩∘"
and "ℛ⇩∘ vint_uminus = ℤ⇩∘"
proof-
show v11: "v11 vint_uminus"
proof(intro v11I)
show vsv: "vsv vint_uminus" unfolding vint_uminus_def by simp
interpret vsv vint_uminus by (rule vsv)
show "vsv (vint_uminus¯⇩∘)"
proof(intro vsvI)
show "vbrelation (vint_uminus¯⇩∘)" by clarsimp
fix a b c
assume prems: "⟨a, b⟩ ∈⇩∘ vint_uminus¯⇩∘" "⟨a, c⟩ ∈⇩∘ vint_uminus¯⇩∘"
then have ba: "⟨b, a⟩ ∈⇩∘ vint_uminus" and ca: "⟨c, a⟩ ∈⇩∘ vint_uminus"
by auto
then have b: "b ∈⇩∘ ℤ⇩∘" and c: "c ∈⇩∘ ℤ⇩∘"
by (simp_all add: VLambda_iff2 vint_uminus_def)
from ba ca have "a = -⇩ℤ b" "a = -⇩ℤ c" by simp_all
with ba ca b c show "b = c" by (metis vint_uminus_uminus)
qed
qed
interpret v11 vint_uminus by (rule v11)
show dom: "𝒟⇩∘ vint_uminus = ℤ⇩∘" unfolding vint_uminus_def by simp
have "ℛ⇩∘ vint_uminus ⊆⇩∘ ℤ⇩∘"
proof(intro vsubsetI)
fix y assume "y ∈⇩∘ ℛ⇩∘ vint_uminus"
then obtain x where "x ∈⇩∘ ℤ⇩∘" and y_def: "y = -⇩ℤ x"
unfolding dom[symmetric] by force
then show "y ∈⇩∘ ℤ⇩∘" by (simp add: vint_uminus_closed)
qed
moreover have "ℤ⇩∘ ⊆⇩∘ ℛ⇩∘ vint_uminus"
by (intro vsubsetI)
(metis dom vdomain_atD vint_uminus_closed vint_uminus_uminus)
ultimately show "ℛ⇩∘ vint_uminus = ℤ⇩∘" by simp
qed
text‹Multiplication.›
global_interpretation vint_mult: binop_onto ‹ℤ⇩∘› vint_mult
proof-
have binop: "binop ℤ⇩∘ vint_mult"
proof(intro binopI nopI)
show vsv: "vsv vint_mult" unfolding vint_mult_def by auto
interpret vsv vint_mult by (rule vsv)
show "2⇩ℕ ∈⇩∘ ω" by simp
show dom: "𝒟⇩∘ vint_mult = ℤ⇩∘ ^⇩× 2⇩ℕ" unfolding vint_mult_def by simp
show "ℛ⇩∘ vint_mult ⊆⇩∘ ℤ⇩∘"
proof(intro vsubsetI)
fix y assume "y ∈⇩∘ ℛ⇩∘ vint_mult"
then obtain ab where "ab ∈⇩∘ ℤ⇩∘ ^⇩× 2⇩ℕ" and y_def: "y = vint_mult⦇ab⦈"
unfolding dom[symmetric] by force
then obtain a b
where ab_def: "ab = [a, b]⇩∘" and a: "a ∈⇩∘ ℤ⇩∘" and b: "b ∈⇩∘ ℤ⇩∘"
by blast
then show "y ∈⇩∘ ℤ⇩∘" by (simp add: vint_mult_closed y_def)
qed
qed
interpret binop ‹ℤ⇩∘› vint_mult by (rule binop)
show "binop_onto ℤ⇩∘ vint_mult"
proof(intro binop_ontoI')
show "binop ℤ⇩∘ vint_mult" by (rule binop_axioms)
show "ℤ⇩∘ ⊆⇩∘ ℛ⇩∘ vint_mult"
proof(intro vsubsetI)
fix y assume prems: "y ∈⇩∘ ℤ⇩∘"
moreover from vint_one vint_one_closed have 0: "1 ∈⇩∘ ℤ⇩∘" by auto
ultimately have "y *⇩ℤ 1 ∈⇩∘ ℛ⇩∘ vint_mult" by auto
moreover from prems vint_identity_law_multiplication have "y = y *⇩ℤ 1"
by (simp add: vint_one)
ultimately show "y ∈⇩∘ ℛ⇩∘ vint_mult" by simp
qed
qed
qed
subsection‹Rational numbers›
subsubsection‹Definition›
definition vrat_of_rat :: "rat ⇒ V"
where "vrat_of_rat x = vreal_of_real (real_of_rat x)"
notation vrat_of_rat (‹_⇩ℚ› [999] 999)
declare [[coercion "vrat_of_rat :: rat ⇒ V"]]
definition vrat :: V (‹ℚ⇩∘›)
where "vrat = set (range vrat_of_rat)"
definition rat_of_vrat :: "V ⇒ rat"
where "rat_of_vrat = inv_into UNIV vrat_of_rat"
text‹Rules.›
lemma vrat_of_rat_in_vratI[intro, simp]: "a⇩ℚ ∈⇩∘ ℚ⇩∘" by (simp add: vrat_def)
lemma vrat_of_rat_in_vratE[elim]:
assumes "a ∈⇩∘ ℚ⇩∘"
obtains b where "b⇩ℚ = a"
using assms unfolding vrat_def by auto
subsubsection‹Elementary properties›
lemma vrat_vsubset_vreal: "ℚ⇩∘ ⊆⇩∘ ℝ⇩∘"
unfolding vrat_def vrat_of_rat_def vreal_def using image_cong by auto
lemma vrat_in_Vset_ω2: "ℚ⇩∘ ∈⇩∘ Vset (ω + ω)"
using vrat_vsubset_vreal vreal_in_Vset_ω2 by auto
lemma inj_vrat_of_rat: "inj vrat_of_rat"
using inj_vreal_of_real
unfolding vrat_of_rat_def inj_def of_rat_eq_iff
by force
lemma rat_of_vrat_vrat_of_rat[simp]: "rat_of_vrat (a⇩ℚ) = a"
by (simp add: inj_vrat_of_rat rat_of_vrat_def)
text‹Transfer rules.›
definition cr_vrat :: "V ⇒ rat ⇒ bool"
where "cr_vrat a b ⟷ (a = vrat_of_rat b)"
lemma cr_vrat_right_total[transfer_rule]: "right_total cr_vrat"
unfolding cr_vrat_def right_total_def by simp
lemma cr_vrat_bi_unqie[transfer_rule]: "bi_unique cr_vrat"
unfolding cr_vrat_def bi_unique_def
by (simp add: inj_eq inj_vrat_of_rat)
lemma cr_vrat_transfer_domain_rule[transfer_domain_rule]:
"Domainp cr_vrat = (λx. x ∈⇩∘ ℚ⇩∘)"
unfolding cr_vrat_def by force
lemma vrat_transfer[transfer_rule]:
"(rel_set cr_vrat) (elts ℚ⇩∘) (UNIV::rat set)"
unfolding cr_vrat_def rel_set_def by auto
lemma vrat_of_rat_transfer[transfer_rule]: "cr_vrat (vrat_of_rat a) a"
unfolding cr_vrat_def by auto
subsubsection‹Operations›
lemma vrat_fsingleton_in_fproduct_vrat: "[a⇩ℚ]⇩∘ ∈⇩∘ ℚ⇩∘ ^⇩× 1⇩ℕ" by auto
lemma vrat_fpair_in_fproduct_vrat: "[a⇩ℚ, b⇩ℚ]⇩∘ ∈⇩∘ ℚ⇩∘ ^⇩× 2⇩ℕ" by force
text‹Zero.›
lemma vrat_zero: "0⇩ℚ = (0::V)" by (simp add: vrat_of_rat_def vreal_zero)
text‹One.›
lemma vrat_one: "1⇩ℚ = (1::V)" by (simp add: vreal_one vrat_of_rat_def)
text‹Addition.›
definition vrat_plus :: V
where "vrat_plus =
(λx∈⇩∘ℚ⇩∘ ^⇩× 2⇩ℕ. (rat_of_vrat (x⦇0⇩ℕ⦈) + rat_of_vrat (x⦇1⇩ℕ⦈))⇩ℚ)"
abbreviation vrat_plus_app (infixl "+⇩ℚ" 65)
where "vrat_plus_app a b ≡ vrat_plus⦇a, b⦈⇩∙"
lemma vrat_plus_transfer[transfer_rule]:
includes lifting_syntax
shows "(cr_vrat ===> cr_vrat ===> cr_vrat) (+⇩ℚ) (+)"
using vrat_fpair_in_fproduct_vrat
by (intro rel_funI, unfold vrat_plus_def cr_vrat_def cr_scalar_def)
(simp add: nat_omega_simps)
text‹Multiplication.›
definition vrat_mult :: V
where "vrat_mult =
(λx∈⇩∘ℚ⇩∘ ^⇩× 2⇩ℕ. (rat_of_vrat (x⦇0⇩ℕ⦈) * rat_of_vrat (x⦇1⇩ℕ⦈))⇩ℚ)"
abbreviation vrat_mult_app (infixl "*⇩ℚ" 65)
where "vrat_mult_app a b ≡ vrat_mult⦇a, b⦈⇩∙"
lemma vrat_mult_transfer[transfer_rule]:
includes lifting_syntax
shows "(cr_vrat ===> cr_vrat ===> cr_vrat) (*⇩ℚ) (*)"
using vrat_fpair_in_fproduct_vrat
by (intro rel_funI, unfold vrat_mult_def cr_vrat_def cr_scalar_def)
(simp add: nat_omega_simps)
text‹Unary minus.›
definition vrat_uminus :: V
where "vrat_uminus = (λx∈⇩∘ℚ⇩∘. (uminus (rat_of_vrat x))⇩ℚ)"
abbreviation vrat_uminus_app ("-⇩ℚ _" [81] 80)
where "-⇩ℚ a ≡ vrat_uminus⦇a⦈"
lemma vrat_uminus_transfer[transfer_rule]:
includes lifting_syntax
shows "(cr_vrat ===> cr_vrat) (vrat_uminus_app) (uminus)"
using vrat_fsingleton_in_fproduct_vrat
by (intro rel_funI, unfold vrat_uminus_def cr_vrat_def cr_scalar_def)
(simp add: nat_omega_simps)
text‹Multiplicative inverse.›
definition vrat_inverse :: V
where "vrat_inverse = (λx∈⇩∘ℚ⇩∘. (inverse (rat_of_vrat x))⇩ℚ)"
abbreviation vrat_inverse_app ("(_¯⇩ℚ)" [1000] 999)
where "a¯⇩ℚ ≡ vrat_inverse⦇a⦈"
lemma vrat_inverse_transfer[transfer_rule]:
includes lifting_syntax
shows "(cr_vrat ===> cr_vrat) (vrat_inverse_app) (inverse)"
using vrat_fsingleton_in_fproduct_vrat
by (intro rel_funI, unfold vrat_inverse_def cr_vrat_def cr_scalar_def)
(simp add: nat_omega_simps)
text‹Order.›
definition vrat_le :: V
where "vrat_le =
set {[a, b]⇩∘ | a b. [a, b]⇩∘ ∈⇩∘ ℚ⇩∘ ^⇩× 2⇩ℕ ∧ rat_of_vrat a ≤ rat_of_vrat b}"
abbreviation vrat_le' ("(_/ ≤⇩ℚ _)" [51, 51] 50)
where "a ≤⇩ℚ b ≡ [a, b]⇩∘ ∈⇩∘ vrat_le"
lemma small_vrat_le[simp]:
"small {[a, b]⇩∘ | a b. [a, b]⇩∘ ∈⇩∘ ℚ⇩∘ ^⇩× 2⇩ℕ ∧ rat_of_vrat a ≤ rat_of_vrat b}"
proof-
have small: "small {[a, b]⇩∘ | a b. [a, b]⇩∘ ∈⇩∘ ℚ⇩∘ ^⇩× 2⇩ℕ}" by simp
show ?thesis by (rule smaller_than_small[OF small]) auto
qed
lemma vrat_le_transfer[transfer_rule]:
includes lifting_syntax
shows "(cr_vrat ===> cr_vrat ===> (=)) vrat_le' (≤)"
using vrat_fsingleton_in_fproduct_vrat
by (intro rel_funI, unfold cr_scalar_def cr_vrat_def vrat_le_def)
(auto simp: nat_omega_simps)
text‹Strict order.›
definition vrat_ls :: V
where "vrat_ls =
set {[a, b]⇩∘ | a b. [a, b]⇩∘ ∈⇩∘ ℚ⇩∘ ^⇩× 2⇩ℕ ∧ rat_of_vrat a < rat_of_vrat b}"
abbreviation vrat_ls' ("(_/ <⇩ℚ _)" [51, 51] 50)
where "a <⇩ℚ b ≡ [a, b]⇩∘ ∈⇩∘ vrat_ls"
lemma small_vrat_ls[simp]:
"small {[a, b]⇩∘ | a b. [a, b]⇩∘ ∈⇩∘ ℚ⇩∘ ^⇩× 2⇩ℕ ∧ rat_of_vrat a < rat_of_vrat b}"
proof-
have small: "small {[a, b]⇩∘ | a b. [a, b]⇩∘ ∈⇩∘ ℚ⇩∘ ^⇩× 2⇩ℕ}" by simp
show ?thesis by (rule smaller_than_small[OF small]) auto
qed
lemma vrat_ls_transfer[transfer_rule]:
includes lifting_syntax
shows "(cr_vrat ===> cr_vrat ===> (=)) vrat_ls' (<)"
by (intro rel_funI, unfold cr_scalar_def cr_vrat_def vrat_ls_def)
(auto simp: nat_omega_simps)
text‹Subtraction.›
definition vrat_minus :: V
where "vrat_minus =
(λx∈⇩∘ℚ⇩∘ ^⇩× 2⇩ℕ. (rat_of_vrat (x⦇0⇩ℕ⦈) - rat_of_vrat (x⦇1⇩ℕ⦈))⇩ℚ)"
abbreviation vrat_minus_app (infixl "-⇩ℚ" 65)
where "vrat_minus_app a b ≡ vrat_minus⦇a, b⦈⇩∙"
lemma vrat_minus_transfer[transfer_rule]:
includes lifting_syntax
shows "(cr_vrat ===> cr_vrat ===> cr_vrat)
(-⇩ℚ) (-)"
using vrat_fpair_in_fproduct_vrat
by (intro rel_funI, unfold vrat_minus_def cr_vrat_def cr_scalar_def)
(simp add: nat_omega_simps)
subsubsection‹Axioms of an ordered field›
text‹The exposition follows Theorem 1.5.5 from the textbook
‹The Real Numbers and Real Analysis› by E. Bloch
\cite{bloch_real_2010}.›
lemma vrat_zero_closed: "0⇩ℚ ∈⇩∘ ℚ⇩∘" by auto
lemma vrat_one_closed: "1⇩ℚ ∈⇩∘ ℚ⇩∘" by auto
lemma vrat_plus_closed:
assumes "x ∈⇩∘ ℚ⇩∘" "y ∈⇩∘ ℚ⇩∘"
shows "x +⇩ℚ y ∈⇩∘ ℚ⇩∘"
proof-
have "x' + y' ∈ UNIV" for x' y' :: rat by simp
from this[untransferred, OF assms] show ?thesis.
qed
lemma vrat_mult_closed:
assumes "x ∈⇩∘ ℚ⇩∘" and "y ∈⇩∘ ℚ⇩∘"
shows "x *⇩ℚ y ∈⇩∘ ℚ⇩∘"
proof-
have "(x'::rat) * y' ∈ UNIV" for x' y' by simp
from this[untransferred, OF assms] show ?thesis.
qed
lemma vrat_uminus_closed:
assumes "x ∈⇩∘ ℚ⇩∘"
shows "-⇩ℚ x ∈⇩∘ ℚ⇩∘"
proof-
have "(-x'::rat) ∈ UNIV" for x' by simp
from this[untransferred, OF assms] show ?thesis.
qed
lemma vrat_inverse_closed:
assumes "x ∈⇩∘ ℚ⇩∘"
shows "x¯⇩ℚ ∈⇩∘ ℚ⇩∘"
proof-
have "inverse (x'::rat) ∈ UNIV" for x' by simp
from this[untransferred, OF assms] show ?thesis.
qed
text‹Associative Law for Addition: Theorem 1.5.5.1.›
lemma vrat_assoc_law_addition:
assumes "x ∈⇩∘ ℚ⇩∘" and "y ∈⇩∘ ℚ⇩∘" and "z ∈⇩∘ ℚ⇩∘"
shows "(x +⇩ℚ y) +⇩ℚ z = x +⇩ℚ (y +⇩ℚ z)"
proof-
have "(x' + y') + z' = x' + (y' + z')" for x' y' z' :: rat by simp
from this[untransferred, OF assms] show ?thesis.
qed
text‹Commutative Law for Addition: Theorem 1.5.5.2.›
lemma vrat_commutative_law_addition:
assumes "x ∈⇩∘ ℚ⇩∘" and "y ∈⇩∘ ℚ⇩∘"
shows "x +⇩ℚ y = y +⇩ℚ x"
proof-
have "x' + y' = y' + x'" for x' y' :: rat by simp
from this[untransferred, OF assms] show ?thesis.
qed
text‹Identity Law for Addition: Theorem 1.5.5.3.›
lemma vrat_identity_law_addition:
assumes [simp]: "x ∈⇩∘ ℚ⇩∘"
shows "x +⇩ℚ 0⇩ℚ = x"
proof-
have "x' + 0 = x'" for x' :: rat by simp
from this[untransferred, OF assms] show ?thesis.
qed
text‹Inverses Law for Addition: Theorem 1.5.5.4.›
lemma vrat_inverses_law_addition:
assumes [simp]: "x ∈⇩∘ ℚ⇩∘"
shows "x +⇩ℚ (-⇩ℚ x) = 0⇩ℚ"
proof-
have "x' + (-x') = 0" for x' :: rat by simp
from this[untransferred, OF assms] show ?thesis.
qed
text‹Associative Law for Multiplication: Theorem 1.5.5.5.›
lemma vrat_assoc_law_multiplication:
assumes "x ∈⇩∘ ℚ⇩∘" and "y ∈⇩∘ ℚ⇩∘" and "z ∈⇩∘ ℚ⇩∘"
shows "(x *⇩ℚ y) *⇩ℚ z = x *⇩ℚ (y *⇩ℚ z)"
proof-
have "(x' * y') * z' = x' * (y' * z')" for x' y' z' :: rat by simp
from this[untransferred, OF assms] show ?thesis.
qed
text‹Commutative Law for Multiplication: Theorem 1.5.5.6.›
lemma vrat_commutative_law_multiplication:
assumes "x ∈⇩∘ ℚ⇩∘" and "y ∈⇩∘ ℚ⇩∘"
shows "x *⇩ℚ y = y *⇩ℚ x"
proof-
have "x' * y' = y' * x'" for x' y' :: rat by simp
from this[untransferred, OF assms] show ?thesis.
qed
text‹Identity Law for multiplication: Theorem 1.5.5.7.›
lemma vrat_identity_law_multiplication:
assumes "x ∈⇩∘ ℚ⇩∘"
shows "x *⇩ℚ 1⇩ℚ = x"
proof-
have "x' * 1 = x'" for x' :: rat by simp
from this[untransferred, OF assms] show ?thesis.
qed
text‹Inverses Law for Multiplication: Definition 2.2.1.8.›
lemma vrat_inverses_law_multiplication:
assumes "x ∈⇩∘ ℚ⇩∘" and "x ≠ 0⇩ℚ"
shows "x *⇩ℚ x¯⇩ℚ = 1⇩ℚ"
proof-
have "x' ≠ 0 ⟹ x' * inverse x' = 1" for x' :: rat by simp
from this[untransferred, OF assms] show ?thesis.
qed
text‹Distributive Law for Multiplication: Theorem 1.5.5.9.›
lemma vrat_distributive_law:
assumes "x ∈⇩∘ ℚ⇩∘" and "y ∈⇩∘ ℚ⇩∘" and "z ∈⇩∘ ℚ⇩∘"
shows "x *⇩ℚ (y +⇩ℚ z) = (x *⇩ℚ y) +⇩ℚ (x *⇩ℚ z)"
proof-
have "x' * (y' + z') = (x' * y') + (x' * z')" for x' y' z' :: rat
by (simp add: algebra_simps)
from this[untransferred, OF assms] show ?thesis.
qed
text‹Trichotomy Law: Theorem 1.5.5.10.›
lemma vrat_trichotomy_law:
assumes "x ∈⇩∘ ℚ⇩∘" and "y ∈⇩∘ ℚ⇩∘"
shows
"(x <⇩ℚ y ∧ ~(x = y) ∧ ~(y <⇩ℚ x)) ∨
(~(x <⇩ℚ y) ∧ x = y ∧ ~(y <⇩ℚ x)) ∨
(~(x <⇩ℚ y) ∧ ~(x = y) ∧ y <⇩ℚ x)"
proof-
have
"(x' < y' ∧ ~(x' = y') ∧ ~(y' < x')) ∨
(~(x' < y') ∧ x' = y' ∧ ~(y' < x')) ∨
(~(x' < y') ∧ ~(x' = y') ∧ y' < x')"
for x' y' z' :: rat
by auto
from this[untransferred, OF assms] show ?thesis.
qed
text‹Transitive Law: Theorem 1.5.5.11.›
lemma vrat_transitive_law:
assumes "x ∈⇩∘ ℚ⇩∘"
and "y ∈⇩∘ ℚ⇩∘"
and "z ∈⇩∘ ℚ⇩∘"
and "x <⇩ℚ y"
and "y <⇩ℚ z"
shows "x <⇩ℚ z"
proof-
have "x' < y' ⟹ y' < z' ⟹ x' < z'" for x' y' z' :: rat by simp
from this[untransferred, OF assms] show ?thesis.
qed
text‹Addition Law of Order: Theorem 1.5.5.12.›
lemma vrat_addition_law_of_order:
assumes "x ∈⇩∘ ℚ⇩∘" and "y ∈⇩∘ ℚ⇩∘" and "z ∈⇩∘ ℚ⇩∘" and "x <⇩ℚ y"
shows "x +⇩ℚ z <⇩ℚ y +⇩ℚ z"
proof-
have "x' < y' ⟹ x' + z' < y' + z'" for x' y' z' :: rat by simp
from this[untransferred, OF assms] show ?thesis.
qed
text‹Multiplication Law of Order: Theorem 1.5.5.13.›
lemma vrat_multiplication_law_of_order:
assumes "x ∈⇩∘ ℚ⇩∘"
and "y ∈⇩∘ ℚ⇩∘"
and "z ∈⇩∘ ℚ⇩∘"
and "x <⇩ℚ y"
and "0⇩ℚ <⇩ℚ z"
shows "x *⇩ℚ z <⇩ℚ y *⇩ℚ z"
proof-
have "x' < y' ⟹ 0 < z' ⟹ x' * z' < y' * z'" for x' y' z' :: rat by simp
from this[untransferred, OF assms] show ?thesis.
qed
text‹Non-Triviality: Theorem 1.5.5.14.›
lemma vrat_non_triviality: "0⇩ℚ ≠ 1⇩ℚ"
proof-
have "0 ≠ (1::rat)" by simp
from this[untransferred] show ?thesis.
qed
subsubsection‹Fundamental properties of other operations›
text‹Minus.›
lemma vrat_minus_closed:
assumes "x ∈⇩∘ ℚ⇩∘" and "y ∈⇩∘ ℚ⇩∘"
shows "x -⇩ℚ y ∈⇩∘ ℚ⇩∘"
proof-
have "x' - y' ∈ UNIV" for x' y' :: rat by simp
from this[untransferred, OF assms] show ?thesis.
qed
lemma vrat_minus_eq_plus_uminus:
assumes "x ∈⇩∘ ℚ⇩∘" and "y ∈⇩∘ ℚ⇩∘"
shows "x -⇩ℚ y = x +⇩ℚ (-⇩ℚ y)"
proof-
have "x' - y' = x' + (-y')" for x' y' :: rat by simp
from this[untransferred, OF assms] show ?thesis.
qed
text‹Unary minus.›
lemma vrat_uminus_uminus:
assumes "x ∈⇩∘ ℚ⇩∘"
shows "x = -⇩ℚ (-⇩ℚ x)"
proof-
have "x' = -(-x')" for x' :: rat by simp
from this[untransferred, OF assms] show ?thesis.
qed
text‹Multiplicative inverse.›
lemma vrat_inverse_inverse:
assumes "x ∈⇩∘ ℚ⇩∘"
shows "x = (x¯⇩ℚ)¯⇩ℚ"
proof-
have "x' = inverse (inverse x')" for x' :: rat by simp
from this[untransferred, OF assms] show ?thesis.
qed
subsubsection‹Further properties›
text‹Addition.›
global_interpretation vrat_plus: binop_onto ‹ℚ⇩∘› vrat_plus
proof-
have binop: "binop ℚ⇩∘ vrat_plus"
proof(intro binopI nopI)
show vsv: "vsv vrat_plus" unfolding vrat_plus_def by auto
interpret vsv vrat_plus by (rule vsv)
show "2⇩ℕ ∈⇩∘ ω" by simp
show dom: "𝒟⇩∘ vrat_plus = ℚ⇩∘ ^⇩× 2⇩ℕ" unfolding vrat_plus_def by simp
show "ℛ⇩∘ vrat_plus ⊆⇩∘ ℚ⇩∘"
proof(intro vsubsetI)
fix y assume "y ∈⇩∘ ℛ⇩∘ vrat_plus"
then obtain ab where "ab ∈⇩∘ ℚ⇩∘ ^⇩× 2⇩ℕ" and y_def: "y = vrat_plus⦇ab⦈"
unfolding dom[symmetric] by force
then obtain a b
where ab_def: "ab = [a, b]⇩∘" and a: "a ∈⇩∘ ℚ⇩∘" and b: "b ∈⇩∘ ℚ⇩∘"
by blast
then show "y ∈⇩∘ ℚ⇩∘" by (simp add: vrat_plus_closed y_def)
qed
qed
interpret binop ‹ℚ⇩∘› vrat_plus by (rule binop)
show "binop_onto ℚ⇩∘ vrat_plus"
proof(intro binop_ontoI')
show "binop ℚ⇩∘ vrat_plus" by (rule binop_axioms)
show "ℚ⇩∘ ⊆⇩∘ ℛ⇩∘ vrat_plus"
proof(intro vsubsetI)
fix y assume prems: "y ∈⇩∘ ℚ⇩∘"
moreover from vrat_zero vrat_zero_closed have 0: "0 ∈⇩∘ ℚ⇩∘"
by auto
ultimately have "y +⇩ℚ 0 ∈⇩∘ ℛ⇩∘ vrat_plus" by auto
moreover from prems vrat_identity_law_addition have "y = y +⇩ℚ 0"
by (simp add: vrat_zero)
ultimately show "y ∈⇩∘ ℛ⇩∘ vrat_plus" by simp
qed
qed
qed
text‹Unary minus.›
global_interpretation vrat_uminus: v11 vrat_uminus
rewrites "𝒟⇩∘ vrat_uminus = ℚ⇩∘"
and "ℛ⇩∘ vrat_uminus = ℚ⇩∘"
proof-
show v11: "v11 vrat_uminus"
proof(intro v11I)
show vsv: "vsv vrat_uminus" unfolding vrat_uminus_def by simp
interpret vsv vrat_uminus by (rule vsv)
show "vsv (vrat_uminus¯⇩∘)"
proof(intro vsvI)
show "vbrelation (vrat_uminus¯⇩∘)" by clarsimp
fix a b c
assume prems: "⟨a, b⟩ ∈⇩∘ vrat_uminus¯⇩∘" "⟨a, c⟩ ∈⇩∘ vrat_uminus¯⇩∘"
then have ba: "⟨b, a⟩ ∈⇩∘ vrat_uminus" and ca: "⟨c, a⟩ ∈⇩∘ vrat_uminus"
by auto
then have b: "b ∈⇩∘ ℚ⇩∘" and c: "c ∈⇩∘ ℚ⇩∘"
by (simp_all add: VLambda_iff2 vrat_uminus_def)
from ba ca have "a = -⇩ℚ b" "a = -⇩ℚ c" by simp_all
with ba ca b c show "b = c" by (metis vrat_uminus_uminus)
qed
qed
interpret v11 vrat_uminus by (rule v11)
show dom: "𝒟⇩∘ vrat_uminus = ℚ⇩∘" unfolding vrat_uminus_def by simp
have "ℛ⇩∘ vrat_uminus ⊆⇩∘ ℚ⇩∘"
proof(intro vsubsetI)
fix y assume "y ∈⇩∘ ℛ⇩∘ vrat_uminus"
then obtain x where "x ∈⇩∘ ℚ⇩∘" and y_def: "y = -⇩ℚ x"
unfolding dom[symmetric] by force
then show "y ∈⇩∘ ℚ⇩∘" by (simp add: vrat_uminus_closed)
qed
moreover have "ℚ⇩∘ ⊆⇩∘ ℛ⇩∘ vrat_uminus"
by (intro vsubsetI)
(metis dom vdomain_atD vrat_uminus_closed vrat_uminus_uminus)
ultimately show "ℛ⇩∘ vrat_uminus = ℚ⇩∘" by simp
qed
text‹Multiplication.›
global_interpretation vrat_mult: binop_onto ‹ℚ⇩∘› vrat_mult
proof-
have binop: "binop ℚ⇩∘ vrat_mult"
proof(intro binopI nopI)
show vsv: "vsv vrat_mult" unfolding vrat_mult_def by auto
interpret vsv vrat_mult by (rule vsv)
show "2⇩ℕ ∈⇩∘ ω" by simp
show dom: "𝒟⇩∘ vrat_mult = ℚ⇩∘ ^⇩× 2⇩ℕ" unfolding vrat_mult_def by simp
show "ℛ⇩∘ vrat_mult ⊆⇩∘ ℚ⇩∘"
proof(intro vsubsetI)
fix y assume "y ∈⇩∘ ℛ⇩∘ vrat_mult"
then obtain ab where "ab ∈⇩∘ ℚ⇩∘ ^⇩× 2⇩ℕ" and y_def: "y = vrat_mult⦇ab⦈"
unfolding dom[symmetric] by force
then obtain a b
where ab_def: "ab = [a, b]⇩∘" and a: "a ∈⇩∘ ℚ⇩∘" and b: "b ∈⇩∘ ℚ⇩∘"
by blast
then show "y ∈⇩∘ ℚ⇩∘" by (simp add: vrat_mult_closed y_def)
qed
qed
interpret binop ‹ℚ⇩∘› vrat_mult by (rule binop)
show "binop_onto ℚ⇩∘ vrat_mult"
proof(intro binop_ontoI')
show "binop ℚ⇩∘ vrat_mult" by (rule binop_axioms)
show "ℚ⇩∘ ⊆⇩∘ ℛ⇩∘ vrat_mult"
proof(intro vsubsetI)
fix y assume prems: "y ∈⇩∘ ℚ⇩∘"
moreover from vrat_one vrat_one_closed have "1 ∈⇩∘ ℚ⇩∘" by auto
ultimately have "y *⇩ℚ 1 ∈⇩∘ ℛ⇩∘ vrat_mult" by auto
moreover from prems vrat_identity_law_multiplication have "y = y *⇩ℚ 1"
by (simp add: vrat_one)
ultimately show "y ∈⇩∘ ℛ⇩∘ vrat_mult" by simp
qed
qed
qed
text‹Multiplicative inverse.›
global_interpretation vrat_inverse: v11 vrat_inverse
rewrites "𝒟⇩∘ vrat_inverse = ℚ⇩∘"
and "ℛ⇩∘ vrat_inverse = ℚ⇩∘"
proof-
show v11: "v11 vrat_inverse"
proof(intro v11I)
show vsv: "vsv vrat_inverse" unfolding vrat_inverse_def by simp
interpret vsv vrat_inverse by (rule vsv)
show "vsv (vrat_inverse¯⇩∘)"
proof(intro vsvI)
show "vbrelation (vrat_inverse¯⇩∘)" by clarsimp
fix a b c
assume prems: "⟨a, b⟩ ∈⇩∘ vrat_inverse¯⇩∘" "⟨a, c⟩ ∈⇩∘ vrat_inverse¯⇩∘"
then have ba: "⟨b, a⟩ ∈⇩∘ vrat_inverse" and ca: "⟨c, a⟩ ∈⇩∘ vrat_inverse"
by auto
then have b: "b ∈⇩∘ ℚ⇩∘" and c: "c ∈⇩∘ ℚ⇩∘"
by (simp_all add: VLambda_iff2 vrat_inverse_def)
from ba ca have "a = b¯⇩ℚ" "a = c¯⇩ℚ" by simp_all
with ba ca b c show "b = c" by (metis vrat_inverse_inverse)
qed
qed
interpret v11 vrat_inverse by (rule v11)
show dom: "𝒟⇩∘ vrat_inverse = ℚ⇩∘" unfolding vrat_inverse_def by simp
have "ℛ⇩∘ vrat_inverse ⊆⇩∘ ℚ⇩∘"
proof(intro vsubsetI)
fix y assume "y ∈⇩∘ ℛ⇩∘ vrat_inverse"
then obtain x where "x ∈⇩∘ ℚ⇩∘" and y_def: "y = x¯⇩ℚ"
unfolding dom[symmetric] by force
then show "y ∈⇩∘ ℚ⇩∘" by (simp add: vrat_inverse_closed)
qed
moreover have "ℚ⇩∘ ⊆⇩∘ ℛ⇩∘ vrat_inverse"
by (intro vsubsetI)
(metis dom vdomain_atD vrat_inverse_closed vrat_inverse_inverse)
ultimately show "ℛ⇩∘ vrat_inverse = ℚ⇩∘" by simp
qed
subsection‹Upper bound on the cardinality of the continuum for \<^typ>‹V››
lemma inj_on_inv_vreal_of_real: "inj_on (inv vreal_of_real) (elts ℝ⇩∘)"
by (intro inj_onI) (fastforce intro: inv_into_injective)
lemma vreal_vlepoll_VPow_omega: "ℝ⇩∘ ≲⇩∘ VPow ω"
proof-
have "elts ℝ⇩∘ ≲ (UNIV::real set)"
unfolding lepoll_def by (auto intro: inj_on_inv_vreal_of_real)
from vlepoll_VPow_omega_if_vreal_lepoll_real[OF this] show ?thesis by simp
qed
text‹\newpage›
end
Theory CZH_EX_Replacement
section‹Example I: absence of replacement in ‹V⇩ω⇩+⇩ω››
theory CZH_EX_Replacement
imports CZH_Sets_ZQR
begin
text‹
The statement of the main result presented in this subsection
can be found in \cite{noauthor_wikipedia_2001}\footnote{
\url{https://en.wikipedia.org/wiki/Zermelo_set_theory}
}
›
definition repl_ex_fun :: V
where "repl_ex_fun = (λi∈⇩∘ω. Vfrom ω i)"
mk_VLambda repl_ex_fun_def
|vsv repl_ex_fun_vsv|
|vdomain repl_ex_fun_vdomain|
|app repl_ex_fun_app|
lemma repl_ex_fun_vrange: "ℛ⇩∘ repl_ex_fun ⊆⇩∘ Vset (ω + ω)"
proof(intro vsv.vsv_vrange_vsubset, unfold repl_ex_fun_vdomain)
fix x assume prems: "x ∈⇩∘ ω"
then show "repl_ex_fun⦇x⦈ ∈⇩∘ Vset (ω + ω)"
proof(induction rule: omega_induct)
case 0 then show ?case
by
(
auto
simp: repl_ex_fun_app intro!: vreal_in_Vset_ω2 omega_vsubset_vreal
)
next
case (succ n)
then have Ord_n: "Ord n" by auto
have Limit_ωω: "Limit (ω + ω)" by auto
from succ show ?case
by
(
auto
simp: Vfrom_succ_Ord[OF Ord_n, of ω] repl_ex_fun_app
intro: Limit_ωω
intro!: omega_vsubset_vreal vreal_in_Vset_ω2
)
qed
qed (unfold repl_ex_fun_def, auto)
lemma Limit_vsv_not_in_Vset_if_vrange_not_in_Vset:
assumes "Limit α" and "ℛ⇩∘ f ∉⇩∘ Vset α"
shows "f ∉⇩∘ Vset α"
proof(rule ccontr, unfold not_not)
assume "f ∈⇩∘ Vset α"
with assms(1) have "ℛ⇩∘ f ∈⇩∘ Vset α" by (simp add: vrange_in_VsetI)
with assms(2) show False by simp
qed
lemma Ord_not_in_Vset:
assumes "Ord α"
shows "α ∉⇩∘ Vset α"
using assms
proof(induction rule: Ord_induct3')
case (succ α)
then have succα: "Vset (succ α) = VPow (Vset α)" by (simp add: Vset_succ)
show ?case
proof(rule ccontr, unfold not_not)
assume "succ α ∈⇩∘ Vset (succ α)"
then have "vinsert α α ∈⇩∘ VPow (Vset α)"
unfolding succα by (simp add: succ_def)
with succ(2) show False by auto
qed
next
case (Limit α) show ?case
proof(rule ccontr, unfold not_not)
assume "(⋃⇩∘ξ∈⇩∘α. ξ) ∈⇩∘ Vset (⋃⇩∘ξ∈⇩∘α. ξ)"
with Limit(1) have "α ∈⇩∘ Vset α" by auto
with Limit(1) obtain i where i: "i ∈⇩∘ α" and "(⋃⇩∘ξ∈⇩∘α. ξ) ∈⇩∘ Vset i"
by (metis Limit_Vfrom_eq Limit_vifunion_def vifunion_iff)
moreover with Limit(1) have "α ∈⇩∘ Vset i" by auto
ultimately have "i ∈⇩∘ Vset i" by auto
with Limit(2)[OF i] show False by auto
qed
qed simp
lemma Ord_succ_vsusbset_Vfrom_succ:
assumes "Transset A" and "Ord a" and "a ∈⇩∘ Vfrom A i"
shows "succ a ⊆⇩∘ Vfrom A (succ i)"
proof(intro vsubsetI)
from Vfrom_in_mono[OF vsubset_reflexive] have i_succi:
"Vfrom A i ∈⇩∘ Vfrom A (succ i)"
by simp
fix x assume prems: "x ∈⇩∘ succ a"
then consider ‹x ∈⇩∘ a› | ‹x = a› unfolding succ_def by auto
then show "x ∈⇩∘ Vfrom A (succ i)"
proof cases
case 1
have "x ∈⇩∘ Vfrom A i" by (rule Vfrom_trans[OF assms(1) 1 assms(3)])
then show "x ∈⇩∘ Vfrom A (succ i)" by (rule Vfrom_trans[OF assms(1) _ i_succi])
next
case 2 from assms(3) show ?thesis
unfolding 2 by (intro Vfrom_trans[OF assms(1) _ i_succi])
qed
qed
lemma Ord_succ_in_Vfrom_succ:
assumes "Transset A" and "Ord a" and "a ∈⇩∘ Vfrom A i"
shows "succ a ∈⇩∘ Vfrom A (succ (succ i))"
using Ord_succ_vsusbset_Vfrom_succ[OF assms] by (simp add: Vfrom_succ)
lemma ω_vplus_in_Vfrom_ω:
assumes "j ∈⇩∘ ω"
shows "ω + j ∈⇩∘ Vfrom ω (succ (2⇩ℕ * j))"
using assms
proof(induction rule: omega_induct)
case 0
have "ω ∈⇩∘ Vfrom ω (succ 0)"
unfolding Vfrom_succ_Ord[where i=0, simplified] by auto
then show ?case by simp
next
case (succ n)
from succ(1) obtain m where n_def: "n = m⇩ℕ" by (auto elim: nat_of_omega)
from succ(1) have ω_succn: "ω + succ n = succ (ω + n)" by (simp add: plus_V_succ_right)
from succ(1) have succ_2succn: "succ (2⇩ℕ * succ n) = succ (succ (succ (2⇩ℕ * n)))"
unfolding n_def by (cs_concl_step nat_omega_simps)+ auto
show ?case
unfolding ω_succn succ_2succn
by (intro Ord_succ_in_Vfrom_succ succ)
(auto simp: succ(1) intro: Ord_is_Transset)
qed
lemma repl_ex_fun_vrange_not_in_Vset: "ℛ⇩∘ repl_ex_fun ∉⇩∘ Vset (ω + ω)"
proof(rule ccontr, unfold not_not)
assume prems: "ℛ⇩∘ repl_ex_fun ∈⇩∘ Vset (ω + ω)"
then have "⋃⇩∘(ℛ⇩∘ repl_ex_fun) ∈⇩∘ Vset (ω + ω)" by (simp add: VUnion_in_VsetI)
moreover have "ω + ω ⊆⇩∘ ⋃⇩∘(ℛ⇩∘ repl_ex_fun)"
proof(intro vsubsetI)
fix x assume prems: "x ∈⇩∘ ω + ω"
from prems consider ‹x ∈⇩∘ ω› | ‹x ∉⇩∘ ω› by auto
then show "x ∈⇩∘ ⋃⇩∘(ℛ⇩∘ repl_ex_fun)"
proof cases
case 1
show ?thesis
proof(rule VUnionI)
show "Vfrom ω 0 ∈⇩∘ ℛ⇩∘ repl_ex_fun"
unfolding repl_ex_fun_def by blast
from 1 show "x ∈⇩∘ Vfrom ω 0" by auto
qed
next
case 2
with prems obtain j where x_def: "x = ω + j" and j: "j ∈⇩∘ ω"
by (auto elim: mem_plus_V_E)
show ?thesis
proof(rule VUnionI)
from j show "Vfrom ω (succ (2⇩ℕ * j)) ∈⇩∘ ℛ⇩∘ repl_ex_fun"
unfolding repl_ex_fun_def by blast
show "x ∈⇩∘ Vfrom ω (succ (2⇩ℕ * j))"
by (rule ω_vplus_in_Vfrom_ω[OF j, folded x_def])
qed
qed
qed
ultimately have "ω + ω ∈⇩∘ Vset (ω + ω)" by auto
with Ord_not_in_Vset show False by auto
qed
lemma repl_ex_fun_not_in_Vset: "repl_ex_fun ∉⇩∘ Vset (ω + ω)"
by (rule Limit_vsv_not_in_Vset_if_vrange_not_in_Vset)
(auto simp: repl_ex_fun_vrange_not_in_Vset)
text‹\newpage›
end
Theory CZH_EX_TS
section‹Example II: topological spaces›
theory CZH_EX_TS
imports CZH_Sets_ZQR
begin
subsection‹Background›
text‹
The section presents elements of the foundations of the theory of topological
spaces formalized in ‹ZFC in HOL›. The definitions were adopted
(with amendments) from the main library of Isabelle/HOL and
\cite{kelley_general_nodate}.
›
named_theorems ts_struct_field_simps
subsection‹‹𝒵›-sequence›
locale 𝒵_vfsequence = 𝒵 α + vfsequence 𝔖 for α 𝔖 +
assumes vrange_vsubset_Vset: "ℛ⇩∘ 𝔖 ⊆⇩∘ Vset α"
text‹Rules.›
lemma 𝒵_vfsequenceI[intro]:
assumes "𝒵 α" and "vfsequence 𝔖" and "ℛ⇩∘ 𝔖 ⊆⇩∘ Vset α"
shows "𝒵_vfsequence α 𝔖"
using assms unfolding 𝒵_vfsequence_def 𝒵_vfsequence_axioms_def by simp
lemmas 𝒵_vfsequenceD[dest] = 𝒵_vfsequence.axioms
lemma 𝒵_vfsequenceE[elim]:
assumes "𝒵_vfsequence α 𝔖"
obtains "𝒵 α" and "vfsequence 𝔖" and "ℛ⇩∘ 𝔖 ⊆⇩∘ Vset α"
using assms by (simp add: 𝒵_vfsequence.axioms(1,2) 𝒵_vfsequence.vrange_vsubset_Vset)
text‹Elementary properties.›
context 𝒵_vfsequence
begin
lemma (in 𝒵_vfsequence) 𝒵_vfsequence_vdomain_in_Vset[intro, simp]:
"𝒟⇩∘ 𝔖 ∈⇩∘ Vset α"
using Axiom_of_Infinity vfsequence_vdomain_in_omega by auto
lemma (in 𝒵_vfsequence) 𝒵_vfsequence_vrange_in_Vset[intro, simp]:
"ℛ⇩∘ 𝔖 ∈⇩∘ Vset α"
using vrange_vsubset_Vset vfsequence_vdomain_in_omega by auto
lemma (in 𝒵_vfsequence) 𝒵_vfsequence_struct_in_Vset: "𝔖 ∈⇩∘ Vset α"
by (auto simp: vrange_vsubset_Vset vsv_Limit_vsv_in_VsetI)
end
subsection‹Topological space›
definition 𝒜 where [ts_struct_field_simps]: "𝒜 = 0"
definition 𝒯 where [ts_struct_field_simps]: "𝒯 = 1⇩ℕ"
locale 𝒵_ts = 𝒵_vfsequence α 𝔖 for α 𝔖 +
assumes 𝒵_ts_length: "2⇩ℕ ≤ vcard 𝔖"
and 𝒵_ts_closed[intro]: "A ∈⇩∘ 𝔖⦇𝒯⦈ ⟹ A ⊆⇩∘ 𝔖⦇𝒜⦈"
and 𝒵_ts_domain[intro, simp]: "𝔖⦇𝒜⦈ ∈⇩∘ 𝔖⦇𝒯⦈"
and 𝒵_ts_vintersection[intro]:
"A ∈⇩∘ 𝔖⦇𝒯⦈ ⟹ B ∈⇩∘ 𝔖⦇𝒯⦈ ⟹ A ∩⇩∘ B ∈⇩∘ 𝔖⦇𝒯⦈"
and 𝒵_ts_VUnion[intro]: "X ⊆⇩∘ 𝔖⦇𝒯⦈ ⟹ ⋃⇩∘X ∈⇩∘ 𝔖⦇𝒯⦈"
text‹Rules.›
lemma 𝒵_tsI[intro]:
assumes "𝒵_vfsequence α 𝔖"
and "2⇩ℕ ≤ vcard 𝔖"
and "⋀A. A ∈⇩∘ 𝔖⦇𝒯⦈ ⟹ A ⊆⇩∘ 𝔖⦇𝒜⦈"
and "𝔖⦇𝒜⦈ ∈⇩∘ 𝔖⦇𝒯⦈"
and "⋀A B. A ∈⇩∘ 𝔖⦇𝒯⦈ ⟹ B ∈⇩∘ 𝔖⦇𝒯⦈ ⟹ A ∩⇩∘ B ∈⇩∘ 𝔖⦇𝒯⦈"
and "⋀X. X ⊆⇩∘ 𝔖⦇𝒯⦈ ⟹ ⋃⇩∘X ∈⇩∘ 𝔖⦇𝒯⦈"
shows "𝒵_ts α 𝔖"
using assms unfolding 𝒵_ts_def 𝒵_ts_axioms_def by simp
lemma 𝒵_tsD[dest]:
assumes "𝒵_ts α 𝔖"
shows "𝒵_vfsequence α 𝔖"
and "2⇩ℕ ≤ vcard 𝔖"
and "⋀A. A ∈⇩∘ 𝔖⦇𝒯⦈ ⟹ A ⊆⇩∘ 𝔖⦇𝒜⦈"
and "𝔖⦇𝒜⦈ ∈⇩∘ 𝔖⦇𝒯⦈"
and "⋀A B. A ∈⇩∘ 𝔖⦇𝒯⦈ ⟹ B ∈⇩∘ 𝔖⦇𝒯⦈ ⟹ A ∩⇩∘ B ∈⇩∘ 𝔖⦇𝒯⦈"
and "⋀X. X ⊆⇩∘ 𝔖⦇𝒯⦈ ⟹ ⋃⇩∘X ∈⇩∘ 𝔖⦇𝒯⦈"
using assms unfolding 𝒵_ts_def 𝒵_ts_axioms_def by auto
lemma 𝒵_tsE[elim]:
assumes "𝒵_ts α 𝔖"
obtains "𝒵_vfsequence α 𝔖"
and "2⇩ℕ ≤ vcard 𝔖"
and "⋀A. A ∈⇩∘ 𝔖⦇𝒯⦈ ⟹ A ⊆⇩∘ 𝔖⦇𝒜⦈"
and "𝔖⦇𝒜⦈ ∈⇩∘ 𝔖⦇𝒯⦈"
and "⋀A B. A ∈⇩∘ 𝔖⦇𝒯⦈ ⟹ B ∈⇩∘ 𝔖⦇𝒯⦈ ⟹ A ∩⇩∘ B ∈⇩∘ 𝔖⦇𝒯⦈"
and "⋀X. X ⊆⇩∘ 𝔖⦇𝒯⦈ ⟹ ⋃⇩∘X ∈⇩∘ 𝔖⦇𝒯⦈"
using assms by auto
text‹Elementary properties.›
lemma (in 𝒵_ts) 𝒵_ts_vempty_in_ts: "0 ∈⇩∘ 𝔖⦇𝒯⦈"
using 𝒵_ts_VUnion[of 0] by simp
subsection‹Indiscrete topology›
definition ts_indiscrete :: "V ⇒ V"
where "ts_indiscrete A = [A, set {0, A}]⇩∘"
named_theorems ts_indiscrete_simps
lemma ts_indiscrete_𝒜[ts_indiscrete_simps]: "ts_indiscrete A⦇𝒜⦈ = A"
unfolding ts_indiscrete_def by (auto simp: ts_struct_field_simps)
lemma ts_indiscrete_𝒯[ts_indiscrete_simps]: "ts_indiscrete A⦇𝒯⦈ = set {0, A}"
unfolding ts_indiscrete_def
by (simp add: ts_struct_field_simps nat_omega_simps)
lemma (in 𝒵) 𝒵_ts_ts_indiscrete:
assumes "A ∈⇩∘ Vset α"
shows "𝒵_ts α (ts_indiscrete A)"
proof(intro 𝒵_tsI)
show struct: "𝒵_vfsequence α (ts_indiscrete A)"
proof(intro 𝒵_vfsequenceI)
show "vfsequence (ts_indiscrete A)" unfolding ts_indiscrete_def by auto
show "ℛ⇩∘ (ts_indiscrete A) ⊆⇩∘ Vset α"
proof(intro vsubsetI)
fix x assume "x ∈⇩∘ ℛ⇩∘ (ts_indiscrete A)"
then consider ‹x = A› | ‹x = set {0, A}›
unfolding ts_indiscrete_def by auto
then show "x ∈⇩∘ Vset α" by cases (simp_all add: Axiom_of_Pairing assms)
qed
qed (simp_all add: 𝒵_axioms)
interpret struct: 𝒵_vfsequence α ‹ts_indiscrete A› by (rule struct)
show "X ⊆⇩∘ ts_indiscrete A⦇𝒯⦈ ⟹ ⋃⇩∘X ∈⇩∘ ts_indiscrete A⦇𝒯⦈" for X
unfolding ts_indiscrete_simps
proof-
assume "X ⊆⇩∘ set {0, A}"
then have "X ∈⇩∘ VPow (set {0, A})" by force
then consider ‹X = 0› | ‹X = set {0}› | ‹X = set {A}› | ‹X = set {0, A}›
by auto
then show "⋃⇩∘X ∈⇩∘ set {0, A}" by cases auto
qed
show "2⇩ℕ ⊆⇩∘ vcard (ts_indiscrete A)" unfolding ts_indiscrete_def by fastforce
qed (auto simp: ts_indiscrete_simps)
text‹\newpage›
end
Theory CZH_EX_Algebra
section‹Example III: abstract algebra›
theory CZH_EX_Algebra
imports CZH_EX_TS
begin
subsection‹Background›
text‹
The section presents several examples of algebraic structures formalized
in ‹ZFC in HOL›. The definitions were adopted (with amendments) from the
main library of Isabelle/HOL.
›
named_theorems sgrp_struct_field_simps
lemmas [sgrp_struct_field_simps] = 𝒜_def
subsection‹Semigroup›
subsubsection‹Foundations›
definition mbinop where [sgrp_struct_field_simps]: "mbinop = 1⇩ℕ"
locale 𝒵_sgrp_basis = 𝒵_vfsequence α 𝔖 + op: binop ‹𝔖⦇𝒜⦈› ‹𝔖⦇mbinop⦈›
for α 𝔖 +
assumes 𝒵_sgrp_length: "vcard 𝔖 = 2⇩ℕ"
and 𝒵_sgrp_binop: "binop (𝔖⦇𝒜⦈) (𝔖⦇mbinop⦈)"
abbreviation sgrp_app :: "V ⇒ V ⇒ V ⇒ V" (infixl ‹⊙⇩∘ı› 70)
where "sgrp_app 𝔖 a b ≡ 𝔖⦇mbinop⦈⦇a, b⦈⇩∙"
notation sgrp_app (infixl ‹⊙⇩∘› 70)
text‹Rules.›
lemma 𝒵_sgrp_basisI[intro]:
assumes "𝒵_vfsequence α 𝔖"
and "vcard 𝔖 = 2⇩ℕ"
and "binop (𝔖⦇𝒜⦈) (𝔖⦇mbinop⦈)"
shows "𝒵_sgrp_basis α 𝔖"
using assms unfolding 𝒵_sgrp_basis_def 𝒵_sgrp_basis_axioms_def by simp
lemma 𝒵_sgrp_basisD[dest]:
assumes "𝒵_sgrp_basis α 𝔖"
shows "𝒵_vfsequence α 𝔖"
and "vcard 𝔖 = 2⇩ℕ"
and "binop (𝔖⦇𝒜⦈) (𝔖⦇mbinop⦈)"
using assms unfolding 𝒵_sgrp_basis_def 𝒵_sgrp_basis_axioms_def by auto
lemma 𝒵_sgrp_basisE[elim]:
assumes "𝒵_sgrp_basis α 𝔖"
shows "𝒵_vfsequence α 𝔖"
and "vcard 𝔖 = 2⇩ℕ"
and "binop (𝔖⦇𝒜⦈) (𝔖⦇mbinop⦈)"
using assms unfolding 𝒵_sgrp_basis_def 𝒵_sgrp_basis_axioms_def by auto
subsubsection‹Simple semigroup›
locale 𝒵_sgrp = 𝒵_sgrp_basis α 𝔖 for α 𝔖 +
assumes 𝒵_sgrp_assoc:
"⟦ a ∈⇩∘ 𝔖⦇𝒜⦈; b ∈⇩∘ 𝔖⦇𝒜⦈; c ∈⇩∘ 𝔖⦇𝒜⦈ ⟧ ⟹
(a ⊙⇩∘⇘𝔖⇙ b) ⊙⇩∘⇘𝔖⇙ c = a ⊙⇩∘⇘𝔖⇙ (b ⊙⇩∘⇘𝔖⇙ c)"
text‹Rules.›
lemma 𝒵_sgrpI[intro]:
assumes "𝒵_sgrp_basis α 𝔖"
and "⋀a b c. ⟦ a ∈⇩∘ 𝔖⦇𝒜⦈; b ∈⇩∘ 𝔖⦇𝒜⦈; c ∈⇩∘ 𝔖⦇𝒜⦈ ⟧ ⟹
(a ⊙⇩∘⇘𝔖⇙ b) ⊙⇩∘⇘𝔖⇙ c = a ⊙⇩∘⇘𝔖⇙ (b ⊙⇩∘⇘𝔖⇙ c)"
shows "𝒵_sgrp α 𝔖"
using assms unfolding 𝒵_sgrp_def 𝒵_sgrp_axioms_def by simp
lemma 𝒵_sgrpD[dest]:
assumes "𝒵_sgrp α 𝔖"
shows "𝒵_sgrp_basis α 𝔖"
and "⋀a b c. ⟦ a ∈⇩∘ 𝔖⦇𝒜⦈; b ∈⇩∘ 𝔖⦇𝒜⦈; c ∈⇩∘ 𝔖⦇𝒜⦈ ⟧ ⟹
(a ⊙⇩∘⇘𝔖⇙ b) ⊙⇩∘⇘𝔖⇙ c = a ⊙⇩∘⇘𝔖⇙ (b ⊙⇩∘⇘𝔖⇙ c)"
using assms unfolding 𝒵_sgrp_def 𝒵_sgrp_axioms_def by simp_all
lemma 𝒵_sgrpE[elim]:
assumes "𝒵_sgrp α 𝔖"
obtains "𝒵_sgrp_basis α 𝔖"
and "⋀a b c. ⟦ a ∈⇩∘ 𝔖⦇𝒜⦈; b ∈⇩∘ 𝔖⦇𝒜⦈; c ∈⇩∘ 𝔖⦇𝒜⦈ ⟧ ⟹
(a ⊙⇩∘⇘𝔖⇙ b) ⊙⇩∘⇘𝔖⇙ c = a ⊙⇩∘⇘𝔖⇙ (b ⊙⇩∘⇘𝔖⇙ c)"
using assms by auto
subsection‹Commutative semigroup›
locale 𝒵_csgrp = 𝒵_sgrp α 𝔖 for α 𝔖 +
assumes 𝒵_csgrp_commutative:
"⟦ a ∈⇩∘ 𝔖⦇𝒜⦈; b ∈⇩∘ 𝔖⦇𝒜⦈ ⟧ ⟹ a ⊙⇩∘⇘𝔖⇙ b = b ⊙⇩∘⇘𝔖⇙ a"
text‹Rules.›
lemma 𝒵_csgrpI[intro]:
assumes "𝒵_sgrp α 𝔖"
and "⋀a b. ⟦ a ∈⇩∘ 𝔖⦇𝒜⦈; b ∈⇩∘ 𝔖⦇𝒜⦈ ⟧ ⟹ a ⊙⇩∘⇘𝔖⇙ b = b ⊙⇩∘⇘𝔖⇙ a"
shows "𝒵_csgrp α 𝔖"
using assms unfolding 𝒵_csgrp_def 𝒵_csgrp_axioms_def by simp
lemma 𝒵_csgrpD[dest]:
assumes "𝒵_csgrp α 𝔖"
shows "𝒵_sgrp α 𝔖"
and "⋀a b. ⟦ a ∈⇩∘ 𝔖⦇𝒜⦈; b ∈⇩∘ 𝔖⦇𝒜⦈ ⟧ ⟹ a ⊙⇩∘⇘𝔖⇙ b = b ⊙⇩∘⇘𝔖⇙ a"
using assms unfolding 𝒵_csgrp_def 𝒵_csgrp_axioms_def by simp_all
lemma 𝒵_csgrpE[elim]:
assumes "𝒵_csgrp α 𝔖"
obtains "𝒵_sgrp α 𝔖"
and "⋀a b. ⟦ a ∈⇩∘ 𝔖⦇𝒜⦈; b ∈⇩∘ 𝔖⦇𝒜⦈ ⟧ ⟹ a ⊙⇩∘⇘𝔖⇙ b = b ⊙⇩∘⇘𝔖⇙ a"
using assms by auto
subsection‹Semiring›
subsubsection‹Foundations›
definition vplus :: V where [sgrp_struct_field_simps]: "vplus = 1⇩ℕ"
definition vmult :: V where [sgrp_struct_field_simps]: "vmult = 2⇩ℕ"
abbreviation vplus_app :: "V ⇒ V ⇒ V ⇒ V" (infixl ‹+⇩∘ı› 65)
where "a +⇩∘⇘𝔖⇙ b ≡ 𝔖⦇vplus⦈⦇a,b⦈⇩∙"
notation vplus_app (infixl ‹+⇩∘ı› 65)
abbreviation vmult_app :: "V ⇒ V ⇒ V ⇒ V" (infixl ‹*⇩∘ı› 70)
where "a *⇩∘⇘𝔖⇙ b ≡ 𝔖⦇vmult⦈⦇a,b⦈⇩∙"
notation vmult_app (infixl ‹*⇩∘ı› 70)
subsubsection‹Simple semiring›
locale 𝒵_srng = 𝒵_vfsequence α 𝔖 for α 𝔖 +
assumes 𝒵_srng_length: "vcard 𝔖 = 3⇩ℕ"
and 𝒵_srng_𝒵_csgrp_vplus: "𝒵_csgrp α [𝔖⦇𝒜⦈, 𝔖⦇vplus⦈]⇩∘"
and 𝒵_srng_𝒵_sgrp_vmult: "𝒵_sgrp α [𝔖⦇𝒜⦈, 𝔖⦇vmult⦈]⇩∘"
and 𝒵_srng_distrib_right:
"⟦ a ∈⇩∘ 𝔖⦇𝒜⦈; b ∈⇩∘ 𝔖⦇𝒜⦈; c ∈⇩∘ 𝔖⦇𝒜⦈ ⟧ ⟹
(a +⇩∘⇘𝔖⇙ b) *⇩∘⇘𝔖⇙ c = (a *⇩∘⇘𝔖⇙ c) +⇩∘⇘𝔖⇙ (b *⇩∘⇘𝔖⇙ c)"
and 𝒵_srng_distrib_left:
"⟦ a ∈⇩∘ 𝔖⦇𝒜⦈; b ∈⇩∘ 𝔖⦇𝒜⦈; c ∈⇩∘ 𝔖⦇𝒜⦈ ⟧ ⟹
a *⇩∘⇘𝔖⇙ (b +⇩∘⇘𝔖⇙ c) = (a *⇩∘⇘𝔖⇙ b) +⇩∘⇘𝔖⇙ (a *⇩∘⇘𝔖⇙ c)"
begin
sublocale vplus: 𝒵_csgrp α ‹[𝔖⦇𝒜⦈, 𝔖⦇vplus⦈]⇩∘›
rewrites "[𝔖⦇𝒜⦈, 𝔖⦇vplus⦈]⇩∘⦇𝒜⦈ = 𝔖⦇𝒜⦈"
and "[𝔖⦇𝒜⦈, 𝔖⦇vplus⦈]⇩∘⦇mbinop⦈ = 𝔖⦇vplus⦈"
and "sgrp_app [𝔖⦇𝒜⦈, 𝔖⦇vplus⦈]⇩∘ = vplus_app 𝔖"
proof(rule 𝒵_srng_𝒵_csgrp_vplus)
show "[𝔖⦇𝒜⦈, 𝔖⦇vplus⦈]⇩∘⦇𝒜⦈ = 𝔖⦇𝒜⦈"
and [simp]: "[𝔖⦇𝒜⦈, 𝔖⦇vplus⦈]⇩∘⦇mbinop⦈ = 𝔖⦇vplus⦈"
by (auto simp: 𝒜_def mbinop_def nat_omega_simps)
show "(⊙⇩∘⇘[𝔖⦇𝒜⦈, 𝔖⦇vplus⦈]⇩∘⇙) = (+⇩∘⇘𝔖⇙)" by simp
qed
sublocale vmult: 𝒵_sgrp α ‹[𝔖⦇𝒜⦈, 𝔖⦇vmult⦈]⇩∘›
rewrites "[𝔖⦇𝒜⦈, 𝔖⦇vmult⦈]⇩∘⦇𝒜⦈ = 𝔖⦇𝒜⦈"
and "[𝔖⦇𝒜⦈, 𝔖⦇vmult⦈]⇩∘⦇mbinop⦈ = 𝔖⦇vmult⦈"
and "sgrp_app [𝔖⦇𝒜⦈, 𝔖⦇vmult⦈]⇩∘ = vmult_app 𝔖"
proof(rule 𝒵_srng_𝒵_sgrp_vmult)
show "[𝔖⦇𝒜⦈, 𝔖⦇vmult⦈]⇩∘⦇𝒜⦈ = 𝔖⦇𝒜⦈"
and [simp]: "[𝔖⦇𝒜⦈, 𝔖⦇vmult⦈]⇩∘⦇mbinop⦈ = 𝔖⦇vmult⦈"
by (auto simp: 𝒜_def mbinop_def nat_omega_simps)
show "(⊙⇩∘⇘[𝔖⦇𝒜⦈, 𝔖⦇vmult⦈]⇩∘⇙) = (*⇩∘⇘𝔖⇙)" by simp
qed
end
text‹Rules.›
lemma 𝒵_srngI[intro]:
assumes "𝒵_vfsequence α 𝔖"
and "vcard 𝔖 = 3⇩ℕ"
and "𝒵_csgrp α [𝔖⦇𝒜⦈, 𝔖⦇vplus⦈]⇩∘"
and "𝒵_sgrp α [𝔖⦇𝒜⦈, 𝔖⦇vmult⦈]⇩∘"
and "⋀a b c. ⟦ a ∈⇩∘ 𝔖⦇𝒜⦈; b ∈⇩∘ 𝔖⦇𝒜⦈; c ∈⇩∘ 𝔖⦇𝒜⦈ ⟧ ⟹
(a +⇩∘⇘𝔖⇙ b) *⇩∘⇘𝔖⇙ c = (a *⇩∘⇘𝔖⇙ c) +⇩∘⇘𝔖⇙ (b *⇩∘⇘𝔖⇙ c)"
and "⋀a b c. ⟦ a ∈⇩∘ 𝔖⦇𝒜⦈; b ∈⇩∘ 𝔖⦇𝒜⦈; c ∈⇩∘ 𝔖⦇𝒜⦈ ⟧ ⟹
a *⇩∘⇘𝔖⇙ (b +⇩∘⇘𝔖⇙ c) = (a *⇩∘⇘𝔖⇙ b) +⇩∘⇘𝔖⇙ (a *⇩∘⇘𝔖⇙ c)"
shows "𝒵_srng α 𝔖"
using assms unfolding 𝒵_srng_def 𝒵_srng_axioms_def by simp
lemma 𝒵_srngD[dest]:
assumes "𝒵_srng α 𝔖"
shows "𝒵_vfsequence α 𝔖"
and "vcard 𝔖 = 3⇩ℕ"
and "𝒵_csgrp α [𝔖⦇𝒜⦈, 𝔖⦇vplus⦈]⇩∘"
and "𝒵_sgrp α [𝔖⦇𝒜⦈, 𝔖⦇vmult⦈]⇩∘"
and "⋀a b c. ⟦ a ∈⇩∘ 𝔖⦇𝒜⦈; b ∈⇩∘ 𝔖⦇𝒜⦈; c ∈⇩∘ 𝔖⦇𝒜⦈ ⟧ ⟹
(a +⇩∘⇘𝔖⇙ b) *⇩∘⇘𝔖⇙ c = (a *⇩∘⇘𝔖⇙ c) +⇩∘⇘𝔖⇙ (b *⇩∘⇘𝔖⇙ c)"
and "⋀a b c. ⟦ a ∈⇩∘ 𝔖⦇𝒜⦈; b ∈⇩∘ 𝔖⦇𝒜⦈; c ∈⇩∘ 𝔖⦇𝒜⦈ ⟧ ⟹
a *⇩∘⇘𝔖⇙ (b +⇩∘⇘𝔖⇙ c) = (a *⇩∘⇘𝔖⇙ b) +⇩∘⇘𝔖⇙ (a *⇩∘⇘𝔖⇙ c)"
using assms unfolding 𝒵_srng_def 𝒵_srng_axioms_def by simp_all
lemma 𝒵_srngE[elim]:
assumes "𝒵_srng α 𝔖"
obtains "𝒵_vfsequence α 𝔖"
and "vcard 𝔖 = 3⇩ℕ"
and "𝒵_csgrp α [𝔖⦇𝒜⦈, 𝔖⦇vplus⦈]⇩∘"
and "𝒵_sgrp α [𝔖⦇𝒜⦈, 𝔖⦇vmult⦈]⇩∘"
and "⋀a b c. ⟦ a ∈⇩∘ 𝔖⦇𝒜⦈; b ∈⇩∘ 𝔖⦇𝒜⦈; c ∈⇩∘ 𝔖⦇𝒜⦈ ⟧ ⟹
(a +⇩∘⇘𝔖⇙ b) *⇩∘⇘𝔖⇙ c = (a *⇩∘⇘𝔖⇙ c) +⇩∘⇘𝔖⇙ (b *⇩∘⇘𝔖⇙ c)"
and "⋀a b c. ⟦ a ∈⇩∘ 𝔖⦇𝒜⦈; b ∈⇩∘ 𝔖⦇𝒜⦈; c ∈⇩∘ 𝔖⦇𝒜⦈ ⟧ ⟹
a *⇩∘⇘𝔖⇙ (b +⇩∘⇘𝔖⇙ c) = (a *⇩∘⇘𝔖⇙ b) +⇩∘⇘𝔖⇙ (a *⇩∘⇘𝔖⇙ c)"
using assms unfolding 𝒵_srng_def 𝒵_srng_axioms_def by auto
subsection‹Integer numbers form a semiring›
definition vint_struct :: V (‹𝔖⇩ℤ›)
where "vint_struct = [ℤ⇩∘, vint_plus, vint_mult]⇩∘"
named_theorems vint_struct_simps
lemma vint_struct_𝒜[vint_struct_simps]: "𝔖⇩ℤ⦇𝒜⦈ = ℤ⇩∘"
unfolding vint_struct_def by (auto simp: sgrp_struct_field_simps)
lemma vint_struct_vplus[vint_struct_simps]: "𝔖⇩ℤ⦇vplus⦈ = vint_plus"
unfolding vint_struct_def
by (simp add: sgrp_struct_field_simps nat_omega_simps)
lemma vint_struct_vmult[vint_struct_simps]: "𝔖⇩ℤ⦇vmult⦈ = vint_mult"
unfolding vint_struct_def
by (simp add: sgrp_struct_field_simps nat_omega_simps)
context 𝒵
begin
lemma 𝒵_srng_vint: "𝒵_srng α 𝔖⇩ℤ"
proof(intro 𝒵_srngI, unfold vint_struct_simps)
interpret 𝔖: vfsequence ‹𝔖⇩ℤ› unfolding vint_struct_def by simp
show vint_struct: "𝒵_vfsequence α 𝔖⇩ℤ"
proof(intro 𝒵_vfsequenceI)
show "vfsequence 𝔖⇩ℤ" unfolding vint_struct_def by simp
show "ℛ⇩∘ 𝔖⇩ℤ ⊆⇩∘ Vset α"
proof(intro vsubsetI)
fix x assume "x ∈⇩∘ ℛ⇩∘ 𝔖⇩ℤ"
then consider ‹x = ℤ⇩∘› | ‹x = vint_plus› | ‹x = vint_mult›
unfolding vint_struct_def by fastforce
then show "x ∈⇩∘ Vset α"
proof cases
case 1 with 𝒵_Vset_ω2_vsubset_Vset vint_in_Vset_ω2 show ?thesis by auto
next
case 2
have "𝒟⇩∘ vint_plus ∈⇩∘ Vset α"
unfolding vint_plus.nop_vdomain
proof(rule Limit_vcpower_in_VsetI)
from Axiom_of_Infinity show "2⇩ℕ ∈⇩∘ Vset α" by auto
from 𝒵_Vset_ω2_vsubset_Vset show "ℤ⇩∘ ∈⇩∘ Vset α"
by (auto intro: vint_in_Vset_ω2)
qed auto
moreover from 𝒵_Vset_ω2_vsubset_Vset have "ℛ⇩∘ vint_plus ∈⇩∘ Vset α"
unfolding vint_plus.nop_onto_vrange by (auto intro: vint_in_Vset_ω2)
ultimately show "x ∈⇩∘ Vset α"
unfolding 2
by (simp add: rel_VLambda.vbrelation_Limit_in_VsetI vint_plus_def)
next
case 3
have "𝒟⇩∘ vint_mult ∈⇩∘ Vset α"
unfolding vint_mult.nop_vdomain
proof(rule Limit_vcpower_in_VsetI)
from Axiom_of_Infinity show "2⇩ℕ ∈⇩∘ Vset α" by auto
from 𝒵_Vset_ω2_vsubset_Vset show "ℤ⇩∘ ∈⇩∘ Vset α"
by (auto intro: vint_in_Vset_ω2)
qed auto
moreover from 𝒵_Vset_ω2_vsubset_Vset Axiom_of_Infinity have
"ℛ⇩∘ vint_mult ∈⇩∘ Vset α"
unfolding vint_mult.nop_onto_vrange by (auto intro: vint_in_Vset_ω2)
ultimately show "x ∈⇩∘ Vset α"
unfolding 3
by (simp add: rel_VLambda.vbrelation_Limit_in_VsetI vint_mult_def)
qed
qed
qed (simp add: 𝒵_axioms)
interpret vint_struct: 𝒵_vfsequence α ‹𝔖⇩ℤ› by (rule vint_struct)
show "vcard 𝔖⇩ℤ = 3⇩ℕ"
unfolding vint_struct_def by (simp add: nat_omega_simps)
have [vint_struct_simps]:
"[ℤ⇩∘, vint_plus]⇩∘⦇𝒜⦈ = ℤ⇩∘" "[ℤ⇩∘, vint_plus]⇩∘⦇mbinop⦈ = vint_plus"
"[ℤ⇩∘, vint_mult]⇩∘⦇𝒜⦈ = ℤ⇩∘" "[ℤ⇩∘, vint_mult]⇩∘⦇mbinop⦈ = vint_mult"
by (auto simp: sgrp_struct_field_simps nat_omega_simps)
have [vint_struct_simps]:
"sgrp_app [ℤ⇩∘, vint_plus]⇩∘ = (+⇩ℤ)"
"sgrp_app [ℤ⇩∘, vint_mult]⇩∘ = (*⇩ℤ)"
unfolding vint_struct_simps by simp_all
show "𝒵_csgrp α [ℤ⇩∘, vint_plus]⇩∘"
proof(intro 𝒵_csgrpI, unfold vint_struct_simps)
show "𝒵_sgrp α [ℤ⇩∘, vint_plus]⇩∘"
proof(intro 𝒵_sgrpI 𝒵_sgrp_basisI, unfold vint_struct_simps)
show "𝒵_vfsequence α [ℤ⇩∘, vint_plus]⇩∘"
proof(intro 𝒵_vfsequenceI)
show "ℛ⇩∘ [ℤ⇩∘, vint_plus]⇩∘ ⊆⇩∘ Vset α"
proof(intro vfsequence_vrange_vconsI)
from 𝒵_Vset_ω2_vsubset_Vset show [simp]: "ℤ⇩∘ ∈⇩∘ Vset α"
by (auto intro: vint_in_Vset_ω2)
show "vint_plus ∈⇩∘ Vset α"
proof(rule vbrelation.vbrelation_Limit_in_VsetI)
from Axiom_of_Infinity show "𝒟⇩∘ vint_plus ∈⇩∘ Vset α"
unfolding vint_plus.nop_vdomain
by (intro Limit_vcpower_in_VsetI) auto
from Axiom_of_Infinity show "ℛ⇩∘ vint_plus ∈⇩∘ Vset α"
unfolding vint_plus.nop_onto_vrange by auto
qed (simp_all add: vint_plus_def)
qed simp_all
qed (simp_all add: 𝒵_axioms)
qed
(
auto simp:
nat_omega_simps
vint_plus.binop_axioms
vint_assoc_law_addition
)
qed (simp add: vint_commutative_law_addition)
show "𝒵_sgrp α [ℤ⇩∘, vint_mult]⇩∘"
proof
(
intro 𝒵_sgrpI 𝒵_sgrp_basisI;
(unfold vint_struct_simps | tactic‹all_tac›)
)
show "𝒵_vfsequence α [ℤ⇩∘, vint_mult]⇩∘"
proof(intro 𝒵_vfsequenceI; (unfold vint_struct_simps | tactic‹all_tac›))
from 𝒵_axioms show "𝒵 α" by simp
show "ℛ⇩∘ [ℤ⇩∘, vint_mult]⇩∘ ⊆⇩∘ Vset α"
proof(intro vfsequence_vrange_vconsI)
from 𝒵_Vset_ω2_vsubset_Vset show [simp]: "ℤ⇩∘ ∈⇩∘ Vset α"
by (auto intro: vint_in_Vset_ω2)
show "vint_mult ∈⇩∘ Vset α"
proof(rule vbrelation.vbrelation_Limit_in_VsetI)
from Axiom_of_Infinity show "𝒟⇩∘ vint_mult ∈⇩∘ Vset α"
unfolding vint_mult.nop_vdomain
by (intro Limit_vcpower_in_VsetI) auto
from Axiom_of_Infinity show "ℛ⇩∘ vint_mult ∈⇩∘ Vset α"
unfolding vint_mult.nop_onto_vrange by auto
qed (simp_all add: vint_mult_def)
qed simp_all
qed auto
qed
(
auto simp:
nat_omega_simps
vint_mult.binop_axioms
vint_assoc_law_multiplication
)
qed
(
auto simp:
vint_commutative_law_multiplication
vint_plus_closed
vint_distributive_law
)
text‹Interpretation.›
interpretation vint: 𝒵_srng α ‹𝔖⇩ℤ›
rewrites "𝔖⇩ℤ⦇𝒜⦈ = ℤ⇩∘"
and "𝔖⇩ℤ⦇vplus⦈ = vint_plus"
and "𝔖⇩ℤ⦇vmult⦈ = vint_mult"
and "vplus_app (𝔖⇩ℤ) = vint_plus_app"
and "vmult_app (𝔖⇩ℤ) = vint_mult_app"
unfolding vint_struct_simps by (rule 𝒵_srng_vint) simp_all
thm vint.vmult.𝒵_sgrp_assoc
thm vint.vplus.𝒵_sgrp_assoc
thm vint.𝒵_srng_distrib_left
end
text‹\newpage›
end
Theory CZH_DG_Introduction
chapter‹Digraphs›
section‹Introduction›
theory CZH_DG_Introduction
imports
"HOL-Library.Rewrite"
CZH_Sets_NOP
CZH_Sets_VNHS
begin
subsection‹Background›
text‹
Many concepts that are normally associated with category theory can be
generalized to directed graphs. It is the goal of
this chapter to expose these generalized concepts and provide the
relevant foundations for the development of the notion of a semicategory
in the next chapter.
It is important to note, however, that it is not the goal of this chapter
to present a comprehensive canonical theory of directed graphs.
Nonetheless, there is little that could prevent one from extending this
body of work by providing canonical results from the theory of directed
graphs.
›
subsection‹Preliminaries›
declare One_nat_def[simp del]
named_theorems slicing_simps
named_theorems slicing_commute
named_theorems slicing_intros
named_theorems dg_op_simps
named_theorems dg_op_intros
named_theorems dg_cs_simps
named_theorems dg_cs_intros
named_theorems dg_shared_cs_simps
named_theorems dg_shared_cs_intros
subsection‹CS setup for foundations›
named_theorems V_cs_simps
named_theorems V_cs_intros
named_theorems Ord_cs_simps
named_theorems Ord_cs_intros
subsubsection‹‹HOL››
lemma (in semilattice_sup) sup_commute':
shows "b' = b ⟹ a' = a ⟹ a ⊔ b = b' ⊔ a'"
and "b' = b ⟹ a' = a ⟹ a ⊔ b' = b ⊔ a'"
and "b' = b ⟹ a' = a ⟹ a' ⊔ b = b' ⊔ a"
and "b' = b ⟹ a' = a ⟹ a ⊔ b' = b ⊔ a'"
and "b' = b ⟹ a' = a ⟹ a' ⊔ b' = b ⊔ a"
by (auto simp: sup.commute)
lemma (in semilattice_inf) inf_commute':
shows "b' = b ⟹ a' = a ⟹ a ⊓ b = b' ⊓ a'"
and "b' = b ⟹ a' = a ⟹ a ⊓ b' = b ⊓ a'"
and "b' = b ⟹ a' = a ⟹ a' ⊓ b = b' ⊓ a"
and "b' = b ⟹ a' = a ⟹ a ⊓ b' = b ⊓ a'"
and "b' = b ⟹ a' = a ⟹ a' ⊓ b' = b ⊓ a"
by (auto simp: inf.commute)
lemmas [V_cs_simps] =
if_P
if_not_P
inf.absorb1
inf.absorb2
sup.absorb1
sup.absorb2
add_0_right
add_0
lemmas [V_cs_intros] =
sup_commute'
inf_commute'
sup.commute
inf.commute
subsubsection‹Foundations›
abbreviation (input) if3 :: "V ⇒ V ⇒ V ⇒ V ⇒ V"
where "if3 a b c ≡
(
λi. if i = 0 ⇒ a
| i = 1⇩ℕ ⇒ b
| otherwise ⇒ c
)"
lemma if3_0[V_cs_simps]: "if3 a b c 0 = a" by auto
lemma if3_1[V_cs_simps]: "if3 a b c (1⇩ℕ) = b" by auto
lemma if3_2[V_cs_simps]: "if3 a b c (2⇩ℕ) = c" by auto
lemma vinsertI1':
assumes "x' = x"
shows "x ∈⇩∘ vinsert x' A"
unfolding assms by (rule vinsertI1)
lemma in_vsingleton[V_cs_intros]:
assumes "f = a"
shows "f ∈⇩∘ set {a}"
unfolding assms by simp
lemma a_in_succ_a: "a ∈⇩∘ succ a" by simp
lemma a_in_succ_xI:
assumes "a ∈⇩∘ x"
shows "a ∈⇩∘ succ x"
using assms by simp
lemma vone_ne[V_cs_intros]: "1⇩ℕ ≠ 0" by clarsimp
lemmas [V_cs_simps] =
vinsert_set_insert_eq
beta
set_empty
vcard_0
lemmas [V_cs_intros] =
mem_not_refl
succ_notin_self
vset_neq_1
vset_neq_2
nin_vinsertI
vinsertI1'
vinsertI2
vfinite_vinsert
vfinite_vsingleton
vdisjnt_nin_right
vdisjnt_nin_left
vunionI1
vunionI2
vunion_in_VsetI
vintersection_in_VsetI
vsubset_reflexive
vsingletonI
small_insert small_empty
Limit_vtimes_in_VsetI
Limit_VPow_in_VsetI
a_in_succ_a
vsubset_vempty
subsubsection‹Binary relations›
lemma vtimesI'[V_cs_intros]:
assumes "ab = ⟨a, b⟩" and "a ∈⇩∘ A" and "b ∈⇩∘ B"
shows "ab ∈⇩∘ A ×⇩∘ B"
using assms by simp
lemma vrange_vcomp_vsubset[V_cs_intros]:
assumes "ℛ⇩∘ r ⊆⇩∘ B"
shows "ℛ⇩∘ (r ∘⇩∘ s) ⊆⇩∘ B"
using assms by auto
lemma vrange_vconst_on_vsubset[V_cs_intros]:
assumes "a ∈⇩∘ R"
shows "ℛ⇩∘ (vconst_on A a) ⊆⇩∘ R"
using assms by auto
lemma vrange_vcomp_eq_vrange[V_cs_simps]:
assumes "𝒟⇩∘ r = ℛ⇩∘ s"
shows "ℛ⇩∘ (r ∘⇩∘ s) = ℛ⇩∘ r"
using assms by (metis vimage_vdomain vrange_vcomp)
lemmas [V_cs_simps] =
vdomain_vsingleton
vdomain_vlrestriction
vdomain_vcomp_vsubset
vdomain_vconverse
vrange_vconverse
vdomain_vconst_on
vconverse_vtimes
vdomain_VLambda
subsubsection‹Single-valued functions›
lemmas (in vsv) [V_cs_intros] = vsv_axioms
lemma vpair_app:
assumes "j = a"
shows "set {⟨a, b⟩}⦇j⦈ = b"
unfolding assms by simp
lemmas [V_cs_simps] =
vpair_app
vsv.vlrestriction_app
vsv_vcomp_at
lemmas (in vsv) [V_cs_intros] = vsv_vimageI2'
lemmas [V_cs_intros] =
vsv_vsingleton
vsv.vsv_vimageI2'
vsv_vcomp
subsubsection‹Injective single-valued functions›
lemmas (in v11) [V_cs_intros] = v11_axioms
lemma (in v11) v11_vconverse_app_in_vdomain':
assumes "y ∈⇩∘ ℛ⇩∘ r" and "A = 𝒟⇩∘ r"
shows "r¯⇩∘⦇y⦈ ∈⇩∘ A"
using assms(1) unfolding assms(2) by (rule v11_vconverse_app_in_vdomain)
lemmas (in v11) [V_cs_intros] = v11_vconverse_app_in_vdomain'
lemmas [V_cs_intros] = v11.v11_vconverse_app_in_vdomain'
lemmas (in v11) [V_cs_simps] =
v11_app_if_vconverse_app[rotated -2]
v11_app_vconverse_app
v11_vconverse_app_app
lemmas [V_cs_simps] =
v11.v11_vconverse_app[rotated -1]
v11.v11_app_vconverse_app
v11.v11_vconverse_app_app
lemmas [V_cs_intros] =
v11D(1)
v11.v11_vconverse
v11_vcomp
subsubsection‹Operations on indexed families of sets›
lemmas [V_cs_simps] =
vprojection_app
vprojection_vdomain
lemmas [V_cs_intros] = vprojection_vsv
subsubsection‹Finite sequences›
lemmas (in vfsequence) [V_cs_intros] = vfsequence_axioms
lemmas (in vfsequence) [V_cs_simps] = vfsequence_vdomain
lemmas [V_cs_simps] = vfsequence.vfsequence_vdomain
lemmas [V_cs_intros] =
vfsequence.vfsequence_vcons
vfsequence_vempty
lemmas [V_cs_simps] =
vfinite_0_left
vfinite_0_right
subsubsection‹Binary relation as a finite sequence›
lemmas [V_cs_simps] =
fconverse_vunion
fconverse_ftimes
vdomain_fflip
subsubsection‹Ordinals›
lemmas [Ord_cs_intros] =
Limit_right_Limit_mult
Limit_left_Limit_mult
Ord_succ_mono
Limit_plus_omega_vsubset_Limit
Limit_plus_nat_in_Limit
subsubsection‹von Neumann hierarchy›
lemma (in 𝒵) omega_in_any[V_cs_intros]:
assumes "α ⊆⇩∘ β"
shows "ω ∈⇩∘ β"
using assms by auto
lemma Ord_vsubset_succ[V_cs_intros]:
assumes "Ord α" and "Ord β" and "α ⊆⇩∘ β"
shows "α ⊆⇩∘ succ β"
by (metis Ord_linear_le Ord_succ assms(1) assms(2) assms(3) leD succ_le_iff)
lemma Ord_in_Vset_succ[V_cs_intros]:
assumes "Ord α" and "a ∈⇩∘ Vset α"
shows "a ∈⇩∘ Vset (succ α)"
using assms by (auto simp: Ord_Vset_in_Vset_succI)
lemma Ord_vsubset_Vset_succ[V_cs_intros]:
assumes "Ord α" and "B ⊆⇩∘ Vset α"
shows "B ⊆⇩∘ Vset (succ α)"
by (intro vsubsetI)
(auto simp: assms Vset_trans Ord_vsubset_in_Vset_succI)
lemmas (in 𝒵) [V_cs_intros] =
omega_in_α
Ord_α
Limit_α
lemmas [V_cs_intros] =
vempty_in_Vset_succ
𝒵.ord_of_nat_in_Vset
Vset_in_mono
Limit_vpair_in_VsetI
Vset_vsubset_mono
Ord_succ
Limit_vempty_in_VsetI
Limit_insert_in_VsetI
vfsequence.vfsequence_Limit_vcons_in_VsetI
vfsequence.vfsequence_Ord_vcons_in_Vset_succI
Limit_vdoubleton_in_VsetI
Limit_omega_in_VsetI
Limit_ftimes_in_VsetI
subsubsection‹‹n›-ary operations›
lemmas [V_cs_simps] =
fflip_app
vdomain_fflip
subsubsection‹Countable ordinals as a set›
named_theorems omega_of_set
named_theorems nat_omega_simps_extra
lemmas [nat_omega_simps_extra] =
add_num_simps
Suc_numeral
Suc_1
le_num_simps
less_numeral_simps(1,2)
less_num_simps
less_one
nat_omega_simps
lemmas [omega_of_set] = nat_omega_simps_extra
lemma set_insert_succ[omega_of_set]:
assumes [simp]: "small b" and "set b = a⇩ℕ"
shows "set (insert (a⇩ℕ) b) = succ (a⇩ℕ)"
unfolding assms(2)[symmetric] by auto
lemma set_0[omega_of_set]: "set {0} = succ 0" by auto
subsubsection‹Sequences›
named_theorems vfsequence_simps
named_theorems vfsequence_intros
lemmas [vfsequence_simps] =
vfsequence.vfsequence_at_last[rotated]
vfsequence.vfsequence_vcard_vcons[rotated]
vfsequence.vfsequence_at_not_last[rotated]
lemmas [vfsequence_intros] =
vfsequence.vfsequence_vcons
vfsequence_vempty
subsubsection‹Further numerals›
named_theorems nat_omega_intros
lemma [nat_omega_intros]:
assumes "a < b"
shows "a⇩ℕ ∈⇩∘ b⇩ℕ"
using assms by simp
lemma [nat_omega_intros]:
assumes "0 < b"
shows "0 ∈⇩∘ b⇩ℕ"
using assms by auto
lemma [nat_omega_intros]:
assumes "a = numeral b"
shows "(0::nat) < a"
using assms by auto
lemma nat_le_if_in[nat_omega_intros]:
assumes "x⇩ℕ ∈⇩∘ y⇩ℕ"
shows "x⇩ℕ ≤ y⇩ℕ"
using assms by auto
lemma vempty_le_nat[nat_omega_intros]: "0 ≤ y⇩ℕ" by auto
lemmas [nat_omega_intros] =
preorder_class.order_refl
preorder_class.eq_refl
subsubsection‹Generally available foundational results›
lemma (in 𝒵) 𝒵_β:
assumes "β = α"
shows "𝒵 β"
unfolding assms by auto
lemmas (in 𝒵) [dg_cs_intros] = 𝒵_β
text‹\newpage›
end
Theory CZH_DG_Digraph
section‹Digraph\label{sec:digraph}›
theory CZH_DG_Digraph
imports CZH_DG_Introduction
begin
subsection‹Background›
named_theorems dg_field_simps
definition Obj :: V where [dg_field_simps]: "Obj = 0"
definition Arr :: V where [dg_field_simps]: "Arr = 1⇩ℕ"
definition Dom :: V where [dg_field_simps]: "Dom = 2⇩ℕ"
definition Cod :: V where [dg_field_simps]: "Cod = 3⇩ℕ"
subsection‹Arrow with a domain and a codomain›
text‹
The definition of and notation for an arrow with a domain and codomain is
adapted from Chapter I-1 in \cite{mac_lane_categories_2010}.
The definition is applicable to digraphs and all other relevant derived
entities, such as semicategories and categories, that are presented in
the subsequent chapters.
In this work, by convention, the definition of an arrow with a domain and a
codomain is nearly always preferred to the explicit use of the domain
and codomain functions for the specification of the fundamental properties
of arrows.
Thus, to say that ‹f› is an arrow with the domain ‹a›, it is preferable
to write ‹f : a ↦⇘ℭ⇙ b› (‹b› can be assumed to be arbitrary) instead
of \<^term>‹f ∈⇩∘ ℭ⦇Arr⦈› and \<^term>‹ℭ⦇Dom⦈⦇f⦈ = a›.
›
definition is_arr :: "V ⇒ V ⇒ V ⇒ V ⇒ bool"
where "is_arr ℭ a b f ⟷ f ∈⇩∘ ℭ⦇Arr⦈ ∧ ℭ⦇Dom⦈⦇f⦈ = a ∧ ℭ⦇Cod⦈⦇f⦈ = b"
syntax "_is_arr" :: "V ⇒ V ⇒ V ⇒ V ⇒ bool" (‹_ : _ ↦ı _› [51, 51, 51] 51)
translations "f : a ↦⇘ℭ⇙ b" ⇌ "CONST is_arr ℭ a b f"
text‹Rules.›
mk_ide is_arr_def
|intro is_arrI|
|dest is_arrD[dest]|
|elim is_arrE[elim]|
lemmas [dg_shared_cs_intros, dg_cs_intros] = is_arrD(1)
lemmas [dg_shared_cs_simps, dg_cs_simps] = is_arrD(2,3)
subsection‹‹Hom›-set›
text‹See Chapter I-8 in \cite{mac_lane_categories_2010}.›
abbreviation Hom :: "V ⇒ V ⇒ V ⇒ V"
where "Hom ℭ a b ≡ set {f. f : a ↦⇘ℭ⇙ b}"
lemma small_Hom[simp]: "small {f. f : a ↦⇘ℭ⇙ b}" unfolding is_arr_def by simp
text‹Rules.›
lemma HomI[dg_shared_cs_intros, dg_cs_intros]:
assumes "f : a ↦⇘ℭ⇙ b"
shows "f ∈⇩∘ Hom ℭ a b"
using assms by auto
lemma in_Hom_iff[dg_shared_cs_simps, dg_cs_simps]:
"f ∈⇩∘ Hom ℭ a b ⟷ f : a ↦⇘ℭ⇙ b"
by simp
text‹
The ‹Hom›-sets in a given digraph are pairwise disjoint. This property
was exposed as Axiom (v) in an alternative definition of a category presented
in Chapter I-8 in \cite{mac_lane_categories_2010}. Within the scope of the
definitional framework employed in this study, this property holds
unconditionally.
›
lemma Hom_vdisjnt:
assumes "a ≠ a' ∨ b ≠ b'"
and "a ∈⇩∘ ℭ⦇Obj⦈"
and "a' ∈⇩∘ ℭ⦇Obj⦈"
and "b ∈⇩∘ ℭ⦇Obj⦈"
and "b' ∈⇩∘ ℭ⦇Obj⦈"
shows "vdisjnt (Hom ℭ a b) (Hom ℭ a' b')"
proof(intro vdisjntI, unfold in_Hom_iff)
fix g f assume "g : a ↦⇘ℭ⇙ b" and "f : a' ↦⇘ℭ⇙ b'"
then have "g ∈⇩∘ ℭ⦇Arr⦈"
and "f ∈⇩∘ ℭ⦇Arr⦈"
and "ℭ⦇Dom⦈⦇g⦈ = a"
and "ℭ⦇Cod⦈⦇g⦈ = b"
and "ℭ⦇Dom⦈⦇f⦈ = a'"
and "ℭ⦇Cod⦈⦇f⦈ = b'"
by (cs_concl cs_simp: dg_cs_simps cs_intro: dg_cs_intros)+
with assms(1) have "ℭ⦇Dom⦈⦇g⦈ ≠ ℭ⦇Dom⦈⦇f⦈ ∨ ℭ⦇Cod⦈⦇g⦈ ≠ ℭ⦇Cod⦈⦇f⦈" by auto
then show "g ≠ f" by clarsimp
qed
subsection‹Digraph: background information›
text‹
The definition of a digraph that is employed in this work is similar
to the definition of a ‹directed graph› presented in Chapter I-2 in
\cite{mac_lane_categories_2010}. However, there are notable differences.
More specifically, the definition is parameterized by a limit ordinal ‹α›,
such that ‹ω < α›; the set of objects is assumed to be a subset
of the set ‹V⇩α› in the von Neumann hierarchy of sets (e.g.,
see \cite{takeuti_introduction_1971}). Such digraphs are called ‹α›-‹digraphs›
to make the dependence on the parameter ‹α› explicit.\footnote{
The prefix ``‹α›-'' may be omitted whenever it is possible to infer the value
of ‹α› from the context. This applies not only to the digraphs, but all
other entities that are parameterized by a limit ordinal ‹α› such that
‹ω < α›.} This definition was inspired by the ideas expressed in
\cite{feferman_set-theoretical_1969}, \cite{sica_doing_2006} and
\cite{shulman_set_2008}.
In ZFC in HOL, the predicate \<^term>‹small› is used for distinguishing the
terms of any type of the form \<^typ>‹'a set› that are isomorphic to elements
of a term of the type \<^typ>‹V› (the elements can be exposed via the predicate
\<^const>‹elts›). Thus, the collection of the elements associated with any term of
the type \<^typ>‹V› (e.g., \<^term>‹elts (a::V)›) is always small
(see the theorem @{thm [source] small_elts} in \cite{paulson_zermelo_2019}).
Therefore, in this study, in an attempt to avoid confusion, the term ``small''
is never used to refer to digraphs.
Instead, a new terminology is introduced in this body of work.
Thus, in this work, an ‹α›-digraph is a tiny ‹α›-digraph if and only if
the set of its objects and the set of its arrows both belong to the set ‹V⇩α›.
This notion is similar to the notion of a small category in the sense of
the definition employed in Chapter I-6 in \cite{mac_lane_categories_2010},
if it is assumed that the ``smallness'' is determined with respect to the
set ‹V⇩α› instead of the universe ‹U›. Also, in what follows, any member of
the set ‹V⇩α› will be referred to as an ‹α›-tiny set.
All of the large (i.e. non-tiny) digraphs
that are considered within the scope of this work have a slightly
unconventional condition associated with the size of their ‹Hom›-sets.
This condition implies that all ‹Hom›-sets of a digraph
are tiny, but it is not equivalent to
all ‹Hom›-sets being tiny. The condition was introduced in an attempt to
resolve some of the issues related to the lack of an analogue of the
Axiom Schema of Replacement closed with respect to ‹V⇩α›.
›
subsection‹Digraph: definition and elementary properties›
locale digraph = 𝒵 α + vfsequence ℭ + Dom: vsv ‹ℭ⦇Dom⦈› + Cod: vsv ‹ℭ⦇Cod⦈›
for α ℭ +
assumes dg_length[dg_cs_simps]: "vcard ℭ = 4⇩ℕ"
and dg_Dom_vdomain[dg_cs_simps]: "𝒟⇩∘ (ℭ⦇Dom⦈) = ℭ⦇Arr⦈"
and dg_Dom_vrange: "ℛ⇩∘ (ℭ⦇Dom⦈) ⊆⇩∘ ℭ⦇Obj⦈"
and dg_Cod_vdomain[dg_cs_simps]: "𝒟⇩∘ (ℭ⦇Cod⦈) = ℭ⦇Arr⦈"
and dg_Cod_vrange: "ℛ⇩∘ (ℭ⦇Cod⦈) ⊆⇩∘ ℭ⦇Obj⦈"
and dg_Obj_vsubset_Vset: "ℭ⦇Obj⦈ ⊆⇩∘ Vset α"
and dg_Hom_vifunion_in_Vset[dg_cs_intros]:
"⟦ A ⊆⇩∘ ℭ⦇Obj⦈; B ⊆⇩∘ ℭ⦇Obj⦈; A ∈⇩∘ Vset α; B ∈⇩∘ Vset α ⟧ ⟹
(⋃⇩∘a∈⇩∘A. ⋃⇩∘b∈⇩∘B. Hom ℭ a b) ∈⇩∘ Vset α"
lemmas [dg_cs_simps] =
digraph.dg_length
digraph.dg_Dom_vdomain
digraph.dg_Cod_vdomain
lemmas [dg_cs_intros] =
digraph.dg_Hom_vifunion_in_Vset
text‹Rules.›
lemma (in digraph) digraph_axioms'[dg_cs_intros]:
assumes "α' = α"
shows "digraph α' ℭ"
unfolding assms by (rule digraph_axioms)
mk_ide rf digraph_def[unfolded digraph_axioms_def]
|intro digraphI|
|dest digraphD[dest]|
|elim digraphE[elim]|
text‹Elementary properties.›
lemma dg_eqI:
assumes "digraph α 𝔄"
and "digraph α 𝔅"
and "𝔄⦇Obj⦈ = 𝔅⦇Obj⦈"
and "𝔄⦇Arr⦈ = 𝔅⦇Arr⦈"
and "𝔄⦇Dom⦈ = 𝔅⦇Dom⦈"
and "𝔄⦇Cod⦈ = 𝔅⦇Cod⦈"
shows "𝔄 = 𝔅"
proof-
interpret 𝔄: digraph α 𝔄 by (rule assms(1))
interpret 𝔅: digraph α 𝔅 by (rule assms(2))
show ?thesis
proof(rule vsv_eqI)
have dom_lhs: "𝒟⇩∘ 𝔄 = 4⇩ℕ" by (cs_concl cs_simp: V_cs_simps dg_cs_simps)
show "a ∈⇩∘ 𝒟⇩∘ 𝔄 ⟹ 𝔄⦇a⦈ = 𝔅⦇a⦈" for a
by (unfold dom_lhs, elim_in_numeral, insert assms)
(auto simp: dg_field_simps)
qed (cs_concl cs_simp: V_cs_simps dg_cs_simps cs_intro: V_cs_intros)+
qed
lemma (in digraph) dg_def: "ℭ = [ℭ⦇Obj⦈, ℭ⦇Arr⦈, ℭ⦇Dom⦈, ℭ⦇Cod⦈]⇩∘"
proof(rule vsv_eqI)
have dom_lhs: "𝒟⇩∘ ℭ = 4⇩ℕ" by (cs_concl cs_simp: V_cs_simps dg_cs_simps)
have dom_rhs: "𝒟⇩∘ [ℭ⦇Obj⦈, ℭ⦇Arr⦈, ℭ⦇Dom⦈, ℭ⦇Cod⦈]⇩∘ = 4⇩ℕ"
by (simp add: nat_omega_simps)
then show "𝒟⇩∘ ℭ = 𝒟⇩∘ [ℭ⦇Obj⦈, ℭ⦇Arr⦈, ℭ⦇Dom⦈, ℭ⦇Cod⦈]⇩∘"
unfolding dom_lhs dom_rhs by simp
show "a ∈⇩∘ 𝒟⇩∘ ℭ ⟹ ℭ⦇a⦈ = [ℭ⦇Obj⦈, ℭ⦇Arr⦈, ℭ⦇Dom⦈, ℭ⦇Cod⦈]⇩∘⦇a⦈" for a
by (unfold dom_lhs, elim_in_numeral, unfold dg_field_simps)
(simp_all add: nat_omega_simps)
qed (auto simp: vsv_axioms)
lemma (in digraph) dg_Obj_if_Dom_vrange:
assumes "a ∈⇩∘ ℛ⇩∘ (ℭ⦇Dom⦈)"
shows "a ∈⇩∘ ℭ⦇Obj⦈"
using assms dg_Dom_vrange by auto
lemma (in digraph) dg_Obj_if_Cod_vrange:
assumes "a ∈⇩∘ ℛ⇩∘ (ℭ⦇Cod⦈)"
shows "a ∈⇩∘ ℭ⦇Obj⦈"
using assms dg_Cod_vrange by auto
lemma (in digraph) dg_is_arrD:
assumes "f : a ↦⇘ℭ⇙ b"
shows "f ∈⇩∘ ℭ⦇Arr⦈"
and "a ∈⇩∘ ℭ⦇Obj⦈"
and "b ∈⇩∘ ℭ⦇Obj⦈"
and "ℭ⦇Dom⦈⦇f⦈ = a"
and "ℭ⦇Cod⦈⦇f⦈ = b"
proof-
from assms show prems: "f ∈⇩∘ ℭ⦇Arr⦈"
and fa[symmetric]: "ℭ⦇Dom⦈⦇f⦈ = a"
and fb[symmetric]: "ℭ⦇Cod⦈⦇f⦈ = b"
by (cs_concl cs_simp: dg_cs_simps cs_intro: dg_cs_intros)+
from digraph_axioms prems have "f ∈⇩∘ 𝒟⇩∘ (ℭ⦇Dom⦈)" "f ∈⇩∘ 𝒟⇩∘ (ℭ⦇Cod⦈)"
by (cs_concl cs_simp: dg_cs_simps)+
with assms show "a ∈⇩∘ ℭ⦇Obj⦈" "b ∈⇩∘ ℭ⦇Obj⦈"
by
(
cs_concl
cs_intro: dg_Obj_if_Dom_vrange dg_Obj_if_Cod_vrange V_cs_intros
cs_simp: fa fb
)+
qed
lemmas [dg_cs_intros] = digraph.dg_is_arrD(1-3)
lemma (in digraph) dg_is_arrE[elim]:
assumes "f : a ↦⇘ℭ⇙ b"
obtains "f ∈⇩∘ ℭ⦇Arr⦈"
and "a ∈⇩∘ ℭ⦇Obj⦈"
and "b ∈⇩∘ ℭ⦇Obj⦈"
and "ℭ⦇Dom⦈⦇f⦈ = a"
and "ℭ⦇Cod⦈⦇f⦈ = b"
using assms by (blast dest: dg_is_arrD)
lemma (in digraph) dg_in_ArrE[elim]:
assumes "f ∈⇩∘ ℭ⦇Arr⦈"
obtains a b where "f : a ↦⇘ℭ⇙ b" and "a ∈⇩∘ ℭ⦇Obj⦈" and "b ∈⇩∘ ℭ⦇Obj⦈"
using assms by (auto dest: dg_is_arrD(2,3) is_arrI)
lemma (in digraph) dg_Hom_in_Vset[dg_cs_intros]:
assumes "a ∈⇩∘ ℭ⦇Obj⦈" and "b ∈⇩∘ ℭ⦇Obj⦈"
shows "Hom ℭ a b ∈⇩∘ Vset α"
proof-
let ?A = ‹set {a}› and ?B = ‹set {b}›
from assms have A: "?A ⊆⇩∘ ℭ⦇Obj⦈" and B: "?B ⊆⇩∘ ℭ⦇Obj⦈" by auto
from assms dg_Obj_vsubset_Vset have "a ∈⇩∘ Vset α" and "b ∈⇩∘ Vset α" by auto
then have a: "set {a} ∈⇩∘ Vset α" and b: "set {b} ∈⇩∘ Vset α"
by (metis Axiom_of_Pairing insert_absorb2)+
from dg_Hom_vifunion_in_Vset[OF A B a b] show "Hom ℭ a b ∈⇩∘ Vset α" by simp
qed
lemmas [dg_cs_intros] = digraph.dg_Hom_in_Vset
text‹Size.›
lemma (in digraph) dg_Arr_vsubset_Vset: "ℭ⦇Arr⦈ ⊆⇩∘ Vset α"
proof(intro vsubsetI)
fix f assume "f ∈⇩∘ ℭ⦇Arr⦈"
then obtain a b
where f: "f : a ↦⇘ℭ⇙ b" and a: "a ∈⇩∘ ℭ⦇Obj⦈" and b: "b ∈⇩∘ ℭ⦇Obj⦈"
by blast
show "f ∈⇩∘ Vset α"
by (rule Vset_trans, rule HomI[OF f], rule dg_Hom_in_Vset[OF a b])
qed
lemma (in digraph) dg_Dom_vsubset_Vset: "ℭ⦇Dom⦈ ⊆⇩∘ Vset α"
by
(
rule Dom.vbrelation_Limit_vsubset_VsetI,
unfold dg_cs_simps,
insert dg_Dom_vrange dg_Obj_vsubset_Vset
)
(auto intro!: dg_Arr_vsubset_Vset)
lemma (in digraph) dg_Cod_vsubset_Vset: "ℭ⦇Cod⦈ ⊆⇩∘ Vset α"
by
(
rule Cod.vbrelation_Limit_vsubset_VsetI,
unfold dg_cs_simps,
insert dg_Cod_vrange dg_Obj_vsubset_Vset
)
(auto intro!: dg_Arr_vsubset_Vset)
lemma (in digraph) dg_digraph_in_Vset_4: "ℭ ∈⇩∘ Vset (α + 4⇩ℕ)"
proof-
note [folded VPow_iff, folded Vset_succ[OF Ord_α], dg_cs_intros] =
dg_Obj_vsubset_Vset
dg_Arr_vsubset_Vset
dg_Dom_vsubset_Vset
dg_Cod_vsubset_Vset
show ?thesis
by (subst dg_def, succ_of_numeral)
(
cs_concl
cs_simp: plus_V_succ_right V_cs_simps
cs_intro: dg_cs_intros V_cs_intros
)
qed
lemma (in digraph) dg_Obj_in_Vset:
assumes "𝒵 β" and "α ∈⇩∘ β"
shows "ℭ⦇Obj⦈ ∈⇩∘ Vset β"
using assms dg_Obj_vsubset_Vset Vset_in_mono by auto
lemma (in digraph) dg_in_Obj_in_Vset[dg_cs_intros]:
assumes "a ∈⇩∘ ℭ⦇Obj⦈"
shows "a ∈⇩∘ Vset α"
using assms dg_Obj_vsubset_Vset by auto
lemma (in digraph) dg_Arr_in_Vset:
assumes "𝒵 β" and "α ∈⇩∘ β"
shows "ℭ⦇Arr⦈ ∈⇩∘ Vset β"
using assms dg_Arr_vsubset_Vset Vset_in_mono by auto
lemma (in digraph) dg_in_Arr_in_Vset[dg_cs_intros]:
assumes "a ∈⇩∘ ℭ⦇Arr⦈"
shows "a ∈⇩∘ Vset α"
using assms dg_Arr_vsubset_Vset by auto
lemma (in digraph) dg_Dom_in_Vset:
assumes "𝒵 β" and "α ∈⇩∘ β"
shows "ℭ⦇Dom⦈ ∈⇩∘ Vset β"
by (meson assms dg_Dom_vsubset_Vset Vset_in_mono vsubset_in_VsetI)
lemma (in digraph) dg_Cod_in_Vset:
assumes "𝒵 β" and "α ∈⇩∘ β"
shows "ℭ⦇Cod⦈ ∈⇩∘ Vset β"
by (meson assms dg_Cod_vsubset_Vset Vset_in_mono vsubset_in_VsetI)
lemma (in digraph) dg_in_Vset:
assumes "𝒵 β" and "α ∈⇩∘ β"
shows "ℭ ∈⇩∘ Vset β"
proof-
interpret β: 𝒵 β by (rule assms(1))
note [dg_cs_intros] =
dg_Obj_in_Vset dg_Arr_in_Vset dg_Dom_in_Vset dg_Cod_in_Vset
from assms(2) show ?thesis
by (subst dg_def) (cs_concl cs_intro: dg_cs_intros V_cs_intros)
qed
lemma (in digraph) dg_digraph_if_ge_Limit:
assumes "𝒵 β" and "α ∈⇩∘ β"
shows "digraph β ℭ"
proof(rule digraphI)
show "vfsequence ℭ" by (simp add: vfsequence_axioms)
show "ℭ⦇Obj⦈ ⊆⇩∘ Vset β"
by (rule vsubsetI)
(meson Vset_in_mono Vset_trans assms(2) dg_Obj_vsubset_Vset vsubsetE)
fix A B assume "A ⊆⇩∘ ℭ⦇Obj⦈" "B ⊆⇩∘ ℭ⦇Obj⦈" "A ∈⇩∘ Vset β" "B ∈⇩∘ Vset β"
then have "(⋃⇩∘a∈⇩∘A. ⋃⇩∘b∈⇩∘B. Hom ℭ a b) ⊆⇩∘ ℭ⦇Arr⦈" by auto
moreover note dg_Arr_vsubset_Vset
moreover have "Vset α ∈⇩∘ Vset β" by (simp add: Vset_in_mono assms(2))
ultimately show "(⋃⇩∘a∈⇩∘A. ⋃⇩∘b∈⇩∘B. Hom ℭ a b) ∈⇩∘ Vset β" by auto
qed (auto simp: assms(1) dg_Dom_vrange dg_Cod_vrange dg_cs_simps)
lemma small_digraph[simp]: "small {ℭ. digraph α ℭ}"
proof(cases ‹𝒵 α›)
case True
with digraph.dg_in_Vset show ?thesis
by (intro down[of _ ‹Vset (α + ω)›] subsetI)
(auto simp: 𝒵.𝒵_Limit_αω 𝒵.𝒵_ω_αω 𝒵.intro 𝒵.𝒵_α_αω)
next
case False
then have "{ℭ. digraph α ℭ} = {}" by auto
then show ?thesis by simp
qed
lemma (in 𝒵) digraphs_in_Vset:
assumes "𝒵 β" and "α ∈⇩∘ β"
shows "set {ℭ. digraph α ℭ} ∈⇩∘ Vset β"
proof(rule vsubset_in_VsetI)
interpret β: 𝒵 β by (rule assms(1))
show "set {ℭ. digraph α ℭ} ⊆⇩∘ Vset (α + 4⇩ℕ)"
proof(intro vsubsetI)
fix ℭ assume "ℭ ∈⇩∘ set {ℭ. digraph α ℭ}"
then interpret digraph α ℭ by simp
show "ℭ ∈⇩∘ Vset (α + 4⇩ℕ)"
unfolding VPow_iff by (rule dg_digraph_in_Vset_4)
qed
from assms(2) show "Vset (α + 4⇩ℕ) ∈⇩∘ Vset β"
by (cs_concl cs_intro: V_cs_intros Ord_cs_intros)
qed
lemma digraph_if_digraph:
assumes "digraph β ℭ"
and "𝒵 α"
and "ℭ⦇Obj⦈ ⊆⇩∘ Vset α"
and "⋀A B. ⟦ A ⊆⇩∘ ℭ⦇Obj⦈; B ⊆⇩∘ ℭ⦇Obj⦈; A ∈⇩∘ Vset α; B ∈⇩∘ Vset α ⟧ ⟹
(⋃⇩∘a∈⇩∘A. ⋃⇩∘b∈⇩∘B. Hom ℭ a b) ∈⇩∘ Vset α"
shows "digraph α ℭ"
proof-
interpret digraph β ℭ by (rule assms(1))
interpret α: 𝒵 α by (rule assms(2))
show ?thesis
proof(intro digraphI)
show "vfsequence ℭ" by (simp add: vfsequence_axioms)
show "(⋃⇩∘a∈⇩∘A. ⋃⇩∘b∈⇩∘B. Hom ℭ a b) ∈⇩∘ Vset α"
if "A ⊆⇩∘ ℭ⦇Obj⦈" "B ⊆⇩∘ ℭ⦇Obj⦈" "A ∈⇩∘ Vset α" "B ∈⇩∘ Vset α" for A B
by (rule assms(4)[OF that])
qed (auto simp: assms(3) dg_Cod_vrange dg_cs_simps intro!: dg_Dom_vrange)
qed
text‹Further elementary properties.›
lemma (in digraph) dg_Dom_app_in_Obj:
assumes "f ∈⇩∘ ℭ⦇Arr⦈"
shows "ℭ⦇Dom⦈⦇f⦈ ∈⇩∘ ℭ⦇Obj⦈"
using assms dg_Dom_vrange by (auto simp: Dom.vsv_vimageI2)
lemma (in digraph) dg_Cod_app_in_Obj:
assumes "f ∈⇩∘ ℭ⦇Arr⦈"
shows "ℭ⦇Cod⦈⦇f⦈ ∈⇩∘ ℭ⦇Obj⦈"
using assms dg_Cod_vrange by (auto simp: Cod.vsv_vimageI2)
lemma (in digraph) dg_Arr_vempty_if_Obj_vempty:
assumes "ℭ⦇Obj⦈ = 0"
shows "ℭ⦇Arr⦈ = 0"
by (metis assms eq0_iff dg_Cod_app_in_Obj)
lemma (in digraph) dg_Dom_vempty_if_Arr_vempty:
assumes "ℭ⦇Arr⦈ = 0"
shows "ℭ⦇Dom⦈ = 0"
using assms Dom.vdomain_vrange_is_vempty
by (auto intro: Dom.vsv_vrange_vempty simp: dg_cs_simps)
lemma (in digraph) dg_Cod_vempty_if_Arr_vempty:
assumes "ℭ⦇Arr⦈ = 0"
shows "ℭ⦇Cod⦈ = 0"
using assms Cod.vdomain_vrange_is_vempty
by (auto intro: Cod.vsv_vrange_vempty simp: dg_cs_simps)
subsection‹Opposite digraph›
subsubsection‹Definition and elementary properties›
text‹See Chapter II-2 in \cite{mac_lane_categories_2010}.›
definition op_dg :: "V ⇒ V"
where "op_dg ℭ = [ℭ⦇Obj⦈, ℭ⦇Arr⦈, ℭ⦇Cod⦈, ℭ⦇Dom⦈]⇩∘"
text‹Components.›
lemma op_dg_components[dg_op_simps]:
shows "op_dg ℭ⦇Obj⦈ = ℭ⦇Obj⦈"
and "op_dg ℭ⦇Arr⦈ = ℭ⦇Arr⦈"
and "op_dg ℭ⦇Dom⦈ = ℭ⦇Cod⦈"
and "op_dg ℭ⦇Cod⦈ = ℭ⦇Dom⦈"
unfolding op_dg_def dg_field_simps by (auto simp: nat_omega_simps)
lemma op_dg_component_intros[dg_op_intros]:
shows "a ∈⇩∘ ℭ⦇Obj⦈ ⟹ a ∈⇩∘ op_dg ℭ⦇Obj⦈"
and "f ∈⇩∘ ℭ⦇Arr⦈ ⟹ f ∈⇩∘ op_dg ℭ⦇Arr⦈"
unfolding dg_op_simps by simp_all
text‹Elementary properties.›
lemma op_dg_is_arr[dg_op_simps]: "f : b ↦⇘op_dg ℭ⇙ a ⟷ f : a ↦⇘ℭ⇙ b"
unfolding dg_op_simps is_arr_def by auto
lemmas [dg_op_intros] = op_dg_is_arr[THEN iffD2]
lemma op_dg_Hom[dg_op_simps]: "Hom (op_dg ℭ) a b = Hom ℭ b a"
unfolding dg_op_simps by simp
subsubsection‹Further properties›
lemma (in digraph) digraph_op[dg_op_intros]: "digraph α (op_dg ℭ)"
proof(intro digraphI, unfold op_dg_components dg_op_simps)
show "vfsequence (op_dg ℭ)" unfolding op_dg_def by simp
show "vcard (op_dg ℭ) = 4⇩ℕ"
unfolding op_dg_def by (simp add: nat_omega_simps)
fix A B assume "A ⊆⇩∘ ℭ⦇Obj⦈" "B ⊆⇩∘ ℭ⦇Obj⦈" "A ∈⇩∘ Vset α" "B ∈⇩∘ Vset α"
then show "⋃⇩∘((λa∈⇩∘A. ⋃⇩∘((λaa∈⇩∘B. Hom ℭ aa a) `⇩∘ B)) `⇩∘ A) ∈⇩∘ Vset α"
by (subst vifunion_vifunion_flip) (intro dg_Hom_vifunion_in_Vset)
qed (auto simp: dg_Dom_vrange dg_Cod_vrange dg_Obj_vsubset_Vset dg_cs_simps)
lemmas digraph_op[dg_op_intros] = digraph.digraph_op
lemma (in digraph) dg_op_dg_op_dg[dg_op_simps]: "op_dg (op_dg ℭ) = ℭ"
by (rule dg_eqI[of α], unfold dg_op_simps)
(simp_all add: digraph_axioms digraph.digraph_op digraph_op)
lemmas dg_op_dg_op_dg[dg_op_simps] = digraph.dg_op_dg_op_dg
lemma eq_op_dg_iff[dg_op_simps]:
assumes "digraph α 𝔄" and "digraph α 𝔅"
shows "op_dg 𝔄 = op_dg 𝔅 ⟷ 𝔄 = 𝔅"
proof
interpret 𝔄: digraph α 𝔄 by (rule assms(1))
interpret 𝔅: digraph α 𝔅 by (rule assms(2))
assume prems: "op_dg 𝔄 = op_dg 𝔅"
show "𝔄 = 𝔅"
proof(rule dg_eqI[of α])
from prems show
"𝔄⦇Obj⦈ = 𝔅⦇Obj⦈" "𝔄⦇Arr⦈ = 𝔅⦇Arr⦈" "𝔄⦇Dom⦈ = 𝔅⦇Dom⦈" "𝔄⦇Cod⦈ = 𝔅⦇Cod⦈"
by (metis prems 𝔄.dg_op_dg_op_dg 𝔅.dg_op_dg_op_dg)+
qed (simp_all add: assms)
qed auto
text‹\newpage›
end
Theory CZH_DG_Small_Digraph
section‹Smallness for digraphs›
theory CZH_DG_Small_Digraph
imports CZH_DG_Digraph
begin
subsection‹Background›
named_theorems dg_small_cs_simps
named_theorems dg_small_cs_intros
subsection‹Tiny digraph›
subsubsection‹Definition and elementary properties›
locale tiny_digraph = 𝒵 α + vfsequence ℭ + Dom: vsv ‹ℭ⦇Dom⦈› + Cod: vsv ‹ℭ⦇Cod⦈›
for α ℭ +
assumes tiny_dg_length[dg_cs_simps]: "vcard ℭ = 4⇩ℕ"
and tiny_dg_Dom_vdomain[dg_cs_simps]: "𝒟⇩∘ (ℭ⦇Dom⦈) = ℭ⦇Arr⦈"
and tiny_dg_Dom_vrange: "ℛ⇩∘ (ℭ⦇Dom⦈) ⊆⇩∘ ℭ⦇Obj⦈"
and tiny_dg_Cod_vdomain[dg_cs_simps]: "𝒟⇩∘ (ℭ⦇Cod⦈) = ℭ⦇Arr⦈"
and tiny_dg_Cod_vrange: "ℛ⇩∘ (ℭ⦇Cod⦈) ⊆⇩∘ ℭ⦇Obj⦈"
and tiny_dg_Obj_in_Vset[dg_small_cs_intros]: "ℭ⦇Obj⦈ ∈⇩∘ Vset α"
and tiny_dg_Arr_in_Vset[dg_small_cs_intros]: "ℭ⦇Arr⦈ ∈⇩∘ Vset α"
lemmas [dg_small_cs_intros] =
tiny_digraph.tiny_dg_Obj_in_Vset
tiny_digraph.tiny_dg_Arr_in_Vset
text‹Rules.›
lemma (in tiny_digraph) tiny_digraph_axioms'[dg_small_cs_intros]:
assumes "α' = α"
shows "tiny_digraph α' ℭ"
unfolding assms by (rule tiny_digraph_axioms)
mk_ide rf tiny_digraph_def[unfolded tiny_digraph_axioms_def]
|intro tiny_digraphI|
|dest tiny_digraphD[dest]|
|elim tiny_digraphE[elim]|
lemma tiny_digraphI':
assumes "digraph α ℭ" and "ℭ⦇Obj⦈ ∈⇩∘ Vset α" and "ℭ⦇Arr⦈ ∈⇩∘ Vset α"
shows "tiny_digraph α ℭ"
using assms by (meson digraphD(5,6,7,8,9) digraph_def tiny_digraphI)
text‹Elementary properties.›
sublocale tiny_digraph ⊆ digraph
proof(rule digraphI)
from tiny_dg_Obj_in_Vset show "ℭ⦇Obj⦈ ⊆⇩∘ Vset α" by auto
fix A B assume "A ⊆⇩∘ ℭ⦇Obj⦈" "B ⊆⇩∘ ℭ⦇Obj⦈" "A ∈⇩∘ Vset α" "B ∈⇩∘ Vset α"
then have "(⋃⇩∘a∈⇩∘A. ⋃⇩∘b∈⇩∘B. Hom ℭ a b) ⊆⇩∘ ℭ⦇Arr⦈" by auto
with tiny_dg_Arr_in_Vset show "(⋃⇩∘a∈⇩∘A. ⋃⇩∘b∈⇩∘B. Hom ℭ a b) ∈⇩∘ Vset α" by blast
qed
(
cs_concl
cs_simp: dg_cs_simps
cs_intro: tiny_dg_Cod_vrange tiny_dg_Dom_vrange dg_cs_intros V_cs_intros
)+
lemmas (in tiny_digraph) tiny_dg_digraph = digraph_axioms
lemmas [dg_small_cs_intros] = tiny_digraph.tiny_dg_digraph
text‹Size.›
lemma (in tiny_digraph) tiny_dg_Dom_in_Vset: "ℭ⦇Dom⦈ ∈⇩∘ Vset α"
proof-
from 𝒵_Limit_αω have "𝒟⇩∘ (ℭ⦇Dom⦈) ∈⇩∘ Vset α"
by (simp add: tiny_dg_Arr_in_Vset dg_cs_simps)
moreover from tiny_dg_Dom_vrange have "ℛ⇩∘ (ℭ⦇Dom⦈) ∈⇩∘ Vset α"
by (auto intro: tiny_dg_Obj_in_Vset)
ultimately show ?thesis
by (simp add: Dom.vbrelation_Limit_in_VsetI 𝒵_Limit_αω)
qed
lemma (in tiny_digraph) tiny_dg_Cod_in_Vset: "ℭ⦇Cod⦈ ∈⇩∘ Vset α"
proof-
from 𝒵_Limit_αω have "𝒟⇩∘ (ℭ⦇Cod⦈) ∈⇩∘ Vset α"
by (simp add: tiny_dg_Arr_in_Vset dg_cs_simps)
moreover from tiny_dg_Cod_vrange have "ℛ⇩∘ (ℭ⦇Cod⦈) ∈⇩∘ Vset α"
by (auto intro: tiny_dg_Obj_in_Vset)
ultimately show ?thesis
by (simp add: Cod.vbrelation_Limit_in_VsetI 𝒵_Limit_αω)
qed
lemma (in tiny_digraph) tiny_dg_in_Vset: "ℭ ∈⇩∘ Vset α"
proof-
note [dg_cs_intros] =
tiny_dg_Obj_in_Vset
tiny_dg_Arr_in_Vset
tiny_dg_Dom_in_Vset
tiny_dg_Cod_in_Vset
show ?thesis
by (subst dg_def) (cs_concl cs_intro: dg_cs_intros V_cs_intros)
qed
lemma small_tiny_digraphs[simp]: "small {ℭ. tiny_digraph α ℭ}"
proof(rule down)
show "{ℭ. tiny_digraph α ℭ} ⊆ elts (set {ℭ. digraph α ℭ})"
by (auto intro: dg_small_cs_intros)
qed
lemma tiny_digraphs_vsubset_Vset: "set {ℭ. tiny_digraph α ℭ} ⊆⇩∘ Vset α"
by (rule vsubsetI) (simp add: tiny_digraph.tiny_dg_in_Vset)
lemma (in digraph) dg_tiny_digraph_if_ge_Limit:
assumes "𝒵 β" and "α ∈⇩∘ β"
shows "tiny_digraph β ℭ"
proof(intro tiny_digraphI')
interpret β: 𝒵 β by (rule assms(1))
show "digraph β ℭ"
by (intro dg_digraph_if_ge_Limit)
(use assms(2) in ‹cs_concl cs_intro: dg_cs_intros›)+
show "ℭ⦇Obj⦈ ∈⇩∘ Vset β" "ℭ⦇Arr⦈ ∈⇩∘ Vset β"
by (auto simp: β.𝒵_β assms(2) dg_Obj_in_Vset dg_Arr_in_Vset)
qed
subsubsection‹Opposite tiny digraph›
lemma (in tiny_digraph) tiny_digraph_op: "tiny_digraph α (op_dg ℭ)"
by (intro tiny_digraphI', unfold dg_op_simps)
(auto simp: tiny_dg_Obj_in_Vset tiny_dg_Arr_in_Vset dg_cs_simps dg_op_intros)
lemmas tiny_digraph_op[dg_op_intros] = tiny_digraph.tiny_digraph_op
subsection‹Finite digraph›
subsubsection‹Definition and elementary properties›
text‹
A finite digraph is a generalization of the concept of a finite category,
as presented in nLab
\cite{noauthor_nlab_nodate}\footnote{
\url{https://ncatlab.org/nlab/show/finite+category}
}.
›
locale finite_digraph = digraph α ℭ for α ℭ +
assumes fin_dg_Obj_vfinite[dg_small_cs_intros]: "vfinite (ℭ⦇Obj⦈)"
and fin_dg_Arr_vfinite[dg_small_cs_intros]: "vfinite (ℭ⦇Arr⦈)"
lemmas [dg_small_cs_intros] =
finite_digraph.fin_dg_Obj_vfinite
finite_digraph.fin_dg_Arr_vfinite
text‹Rules.›
lemma (in finite_digraph) finite_digraph_axioms'[dg_small_cs_intros]:
assumes "α' = α"
shows "finite_digraph α' ℭ"
unfolding assms by (rule finite_digraph_axioms)
mk_ide rf finite_digraph_def[unfolded finite_digraph_axioms_def]
|intro finite_digraphI|
|dest finite_digraphD[dest]|
|elim finite_digraphE[elim]|
text‹Elementary properties.›
sublocale finite_digraph ⊆ tiny_digraph
proof(rule tiny_digraphI')
show "ℭ⦇Obj⦈ ∈⇩∘ Vset α"
by
(
cs_concl cs_intro:
dg_small_cs_intros V_cs_intros
dg_Obj_vsubset_Vset Limit_vfinite_in_VsetI
)
show "ℭ⦇Arr⦈ ∈⇩∘ Vset α"
by
(
cs_concl cs_intro:
dg_small_cs_intros V_cs_intros
dg_Arr_vsubset_Vset Limit_vfinite_in_VsetI
)
qed (auto intro: dg_cs_intros)
lemmas (in finite_digraph) fin_dg_tiny_digraph = tiny_digraph_axioms
lemmas [dg_small_cs_intros] = finite_digraph.fin_dg_tiny_digraph
text‹Size.›
lemma small_finite_digraphs[simp]: "small {ℭ. finite_digraph α ℭ}"
proof(rule down)
show "{ℭ. finite_digraph α ℭ} ⊆ elts (set {ℭ. digraph α ℭ})"
by (auto intro: dg_cs_intros)
qed
lemma finite_digraphs_vsubset_Vset: "set {ℭ. finite_digraph α ℭ} ⊆⇩∘ Vset α"
by
(
force simp:
tiny_digraph.tiny_dg_in_Vset finite_digraph.fin_dg_tiny_digraph
)
subsubsection‹Opposite finite digraph›
lemma (in finite_digraph) fininte_digraph_op: "finite_digraph α (op_dg ℭ)"
by (intro finite_digraphI, unfold dg_op_simps)
(auto simp: dg_small_cs_intros dg_op_intros)
lemmas fininte_digraph_op[dg_op_intros] = finite_digraph.fininte_digraph_op
text‹\newpage›
end
Theory CZH_DG_DGHM
section‹Homomorphism of digraphs›
theory CZH_DG_DGHM
imports CZH_DG_Digraph
begin
subsection‹Background›
named_theorems dghm_cs_simps
named_theorems dghm_cs_intros
named_theorems dg_cn_cs_simps
named_theorems dg_cn_cs_intros
named_theorems dghm_field_simps
definition ObjMap :: V where [dghm_field_simps]: "ObjMap = 0"
definition ArrMap :: V where [dghm_field_simps]: "ArrMap = 1⇩ℕ"
definition HomDom :: V where [dghm_field_simps]: "HomDom = 2⇩ℕ"
definition HomCod :: V where [dghm_field_simps]: "HomCod = 3⇩ℕ"
subsection‹Definition and elementary properties›
text‹
A homomorphism of digraphs, as presented in this work, can be seen as a
generalization of the concept of a functor between categories, as presented in
Chapter I-3 in \cite{mac_lane_categories_2010}, to digraphs.
The generalization is performed by removing the axioms (1) from the definition.
It is expected that the resulting definition is consistent with the conventional
notion of a homomorphism of digraphs in graph theory, but further details
are considered to be outside of the scope of this work.
The definition of a digraph homomorphism is parameterized by a limit ordinal
‹α› such that ‹ω < α›. Such digraph homomorphisms are referred to either as
‹α›-digraph homomorphisms or homomorphisms of ‹α›-digraphs.
Following \cite{mac_lane_categories_2010}, all digraph homomorphisms are
covariant (see Chapter II-2). However, a special notation is adapted for the
digraph homomorphisms from an opposite digraph. Normally, such
digraph homomorphisms will be referred to as the contravariant digraph
homomorphisms, but this convention will not be enforced.
›
locale is_dghm =
𝒵 α + vfsequence 𝔉 + HomDom: digraph α 𝔄 + HomCod: digraph α 𝔅
for α 𝔄 𝔅 𝔉 +
assumes dghm_length[dg_cs_simps]: "vcard 𝔉 = 4⇩ℕ"
and dghm_HomDom[dg_cs_simps]: "𝔉⦇HomDom⦈ = 𝔄"
and dghm_HomCod[dg_cs_simps]: "𝔉⦇HomCod⦈ = 𝔅"
and dghm_ObjMap_vsv: "vsv (𝔉⦇ObjMap⦈)"
and dghm_ArrMap_vsv: "vsv (𝔉⦇ArrMap⦈)"
and dghm_ObjMap_vdomain[dg_cs_simps]: "𝒟⇩∘ (𝔉⦇ObjMap⦈) = 𝔄⦇Obj⦈"
and dghm_ObjMap_vrange: "ℛ⇩∘ (𝔉⦇ObjMap⦈) ⊆⇩∘ 𝔅⦇Obj⦈"
and dghm_ArrMap_vdomain[dg_cs_simps]: "𝒟⇩∘ (𝔉⦇ArrMap⦈) = 𝔄⦇Arr⦈"
and dghm_ArrMap_is_arr:
"f : a ↦⇘𝔄⇙ b ⟹ 𝔉⦇ArrMap⦈⦇f⦈ : 𝔉⦇ObjMap⦈⦇a⦈ ↦⇘𝔅⇙ 𝔉⦇ObjMap⦈⦇b⦈"
syntax "_is_dghm" :: "V ⇒ V ⇒ V ⇒ V ⇒ bool"
(‹(_ :/ _ ↦↦⇩D⇩Gı _)› [51, 51, 51] 51)
translations "𝔉 : 𝔄 ↦↦⇩D⇩G⇘α⇙ 𝔅" ⇌ "CONST is_dghm α 𝔄 𝔅 𝔉"
abbreviation (input) is_cn_dghm :: "V ⇒ V ⇒ V ⇒ V ⇒ bool"
where "is_cn_dghm α 𝔄 𝔅 𝔉 ≡ 𝔉 : op_dg 𝔄 ↦↦⇩D⇩G⇘α⇙ 𝔅"
syntax "_is_cn_dghm" :: "V ⇒ V ⇒ V ⇒ V ⇒ bool"
(‹(_ :/ _ ⇩D⇩G↦↦ı _)› [51, 51, 51] 51)
translations "𝔉 : 𝔄 ⇩D⇩G↦↦⇘α⇙ 𝔅" ⇀ "CONST is_cn_dghm α 𝔄 𝔅 𝔉"
abbreviation all_dghms :: "V ⇒ V"
where "all_dghms α ≡ set {𝔉. ∃𝔄 𝔅. 𝔉 : 𝔄 ↦↦⇩D⇩G⇘α⇙ 𝔅}"
abbreviation dghms :: "V ⇒ V ⇒ V ⇒ V"
where "dghms α 𝔄 𝔅 ≡ set {𝔉. 𝔉 : 𝔄 ↦↦⇩D⇩G⇘α⇙ 𝔅}"
sublocale is_dghm ⊆ ObjMap: vsv ‹𝔉⦇ObjMap⦈›
rewrites "𝒟⇩∘ (𝔉⦇ObjMap⦈) = 𝔄⦇Obj⦈"
by (rule dghm_ObjMap_vsv) (simp add: dg_cs_simps)
sublocale is_dghm ⊆ ArrMap: vsv ‹𝔉⦇ArrMap⦈›
rewrites "𝒟⇩∘ (𝔉⦇ArrMap⦈) = 𝔄⦇Arr⦈"
by (rule dghm_ArrMap_vsv) (simp add: dg_cs_simps)
lemmas [dg_cs_simps] =
is_dghm.dghm_HomDom
is_dghm.dghm_HomCod
is_dghm.dghm_ObjMap_vdomain
is_dghm.dghm_ArrMap_vdomain
lemma (in is_dghm) dghm_ArrMap_is_arr''[dg_cs_intros]:
assumes "f : a ↦⇘𝔄⇙ b" and "𝔉f = 𝔉⦇ArrMap⦈⦇f⦈"
shows "𝔉f : 𝔉⦇ObjMap⦈⦇a⦈ ↦⇘𝔅⇙ 𝔉⦇ObjMap⦈⦇b⦈"
using assms(1) unfolding assms(2) by (rule dghm_ArrMap_is_arr)
lemma (in is_dghm) dghm_ArrMap_is_arr'[dg_cs_intros]:
assumes "f : a ↦⇘𝔄⇙ b"
and "A = 𝔉⦇ObjMap⦈⦇a⦈"
and "B = 𝔉⦇ObjMap⦈⦇b⦈"
shows "𝔉⦇ArrMap⦈⦇f⦈ : A ↦⇘𝔅⇙ B"
using assms(1) unfolding assms(2,3) by (rule dghm_ArrMap_is_arr)
lemmas [dg_cs_intros] = is_dghm.dghm_ArrMap_is_arr'
text‹Rules.›
lemma (in is_dghm) is_dghm_axioms'[dg_cs_intros]:
assumes "α' = α" and "𝔄' = 𝔄" and "𝔅' = 𝔅"
shows "𝔉 : 𝔄' ↦↦⇩D⇩G⇘α'⇙ 𝔅'"
unfolding assms by (rule is_dghm_axioms)
mk_ide rf is_dghm_def[unfolded is_dghm_axioms_def]
|intro is_dghmI|
|dest is_dghmD[dest]|
|elim is_dghmE[elim]|
lemmas [dg_cs_intros] = is_dghmD(3,4)
text‹Elementary properties.›
lemma dghm_eqI:
assumes "𝔊 : 𝔄 ↦↦⇩D⇩G⇘α⇙ 𝔅"
and "𝔉 : ℭ ↦↦⇩D⇩G⇘α⇙ 𝔇"
and "𝔊⦇ObjMap⦈ = 𝔉⦇ObjMap⦈"
and "𝔊⦇ArrMap⦈ = 𝔉⦇ArrMap⦈"
and "𝔄 = ℭ"
and "𝔅 = 𝔇"
shows "𝔊 = 𝔉"
proof-
interpret L: is_dghm α 𝔄 𝔅 𝔊 by (rule assms(1))
interpret R: is_dghm α ℭ 𝔇 𝔉 by (rule assms(2))
show ?thesis
proof(rule vsv_eqI)
have dom: "𝒟⇩∘ 𝔊 = 4⇩ℕ" by (cs_concl cs_simp: dg_cs_simps V_cs_simps)
from assms(5,6) have sup: "𝔊⦇HomDom⦈ = 𝔉⦇HomDom⦈" "𝔊⦇HomCod⦈ = 𝔉⦇HomCod⦈"
by (simp_all add: dg_cs_simps)
show "a ∈⇩∘ 𝒟⇩∘ 𝔊 ⟹ 𝔊⦇a⦈ = 𝔉⦇a⦈" for a
by (unfold dom, elim_in_numeral, insert assms(3,4) sup)
(auto simp: dghm_field_simps)
qed (cs_concl cs_simp: dg_cs_simps V_cs_simps cs_intro: V_cs_intros)+
qed
lemma (in is_dghm) dghm_def: "𝔉 = [𝔉⦇ObjMap⦈, 𝔉⦇ArrMap⦈, 𝔉⦇HomDom⦈, 𝔉⦇HomCod⦈]⇩∘"
proof(rule vsv_eqI)
have dom_lhs: "𝒟⇩∘ 𝔉 = 4⇩ℕ" by (cs_concl cs_simp: dg_cs_simps V_cs_simps)
have dom_rhs: "𝒟⇩∘ [𝔉⦇ObjMap⦈, 𝔉⦇ArrMap⦈, 𝔉⦇HomDom⦈, 𝔉⦇HomCod⦈]⇩∘ = 4⇩ℕ"
by (simp add: nat_omega_simps)
then show "𝒟⇩∘ 𝔉 = 𝒟⇩∘ [𝔉⦇ObjMap⦈, 𝔉⦇ArrMap⦈, 𝔉⦇HomDom⦈, 𝔉⦇HomCod⦈]⇩∘"
unfolding dom_lhs dom_rhs by (simp add: nat_omega_simps)
show "a ∈⇩∘ 𝒟⇩∘ 𝔉 ⟹ 𝔉⦇a⦈ = [𝔉⦇ObjMap⦈, 𝔉⦇ArrMap⦈, 𝔉⦇HomDom⦈, 𝔉⦇HomCod⦈]⇩∘⦇a⦈"
for a
by (unfold dom_lhs, elim_in_numeral, unfold dghm_field_simps)
(simp_all add: nat_omega_simps)
qed (auto simp: vsv_axioms)
lemma (in is_dghm) dghm_ObjMap_app_in_HomCod_Obj[dg_cs_intros]:
assumes "a ∈⇩∘ 𝔄⦇Obj⦈"
shows "𝔉⦇ObjMap⦈⦇a⦈ ∈⇩∘ 𝔅⦇Obj⦈"
using assms dghm_ObjMap_vrange by (blast dest: ObjMap.vsv_vimageI2)
lemmas [dg_cs_intros] = is_dghm.dghm_ObjMap_app_in_HomCod_Obj
lemma (in is_dghm) dghm_ArrMap_vrange: "ℛ⇩∘ (𝔉⦇ArrMap⦈) ⊆⇩∘ 𝔅⦇Arr⦈"
proof(rule vsv.vsv_vrange_vsubset, unfold dg_cs_simps)
fix f assume "f ∈⇩∘ 𝔄⦇Arr⦈"
then obtain a b where "f : a ↦⇘𝔄⇙ b" by auto
then have "𝔉⦇ArrMap⦈⦇f⦈ : 𝔉⦇ObjMap⦈⦇a⦈ ↦⇘𝔅⇙ 𝔉⦇ObjMap⦈⦇b⦈"
by (cs_concl cs_intro: dg_cs_intros)
then show "𝔉⦇ArrMap⦈⦇f⦈ ∈⇩∘ 𝔅⦇Arr⦈" by auto
qed auto
lemma (in is_dghm) dghm_ArrMap_app_in_HomCod_Arr[dg_cs_intros]:
assumes "a ∈⇩∘ 𝔄⦇Arr⦈"
shows "𝔉⦇ArrMap⦈⦇a⦈ ∈⇩∘ 𝔅⦇Arr⦈"
using assms dghm_ArrMap_vrange by (blast dest: ArrMap.vsv_vimageI2)
lemmas [dg_cs_intros] = is_dghm.dghm_ArrMap_app_in_HomCod_Arr
text‹Size.›
lemma (in is_dghm) dghm_ObjMap_vsubset_Vset: "𝔉⦇ObjMap⦈ ⊆⇩∘ Vset α"
by
(
rule ObjMap.vbrelation_Limit_vsubset_VsetI,
insert dghm_ObjMap_vrange HomCod.dg_Obj_vsubset_Vset
)
(auto intro!: HomDom.dg_Obj_vsubset_Vset)
lemma (in is_dghm) dghm_ArrMap_vsubset_Vset: "𝔉⦇ArrMap⦈ ⊆⇩∘ Vset α"
by
(
rule ArrMap.vbrelation_Limit_vsubset_VsetI,
insert dghm_ArrMap_vrange HomCod.dg_Arr_vsubset_Vset
)
(auto intro!: HomDom.dg_Arr_vsubset_Vset)
lemma (in is_dghm) dghm_ObjMap_in_Vset:
assumes "α ∈⇩∘ β"
shows "𝔉⦇ObjMap⦈ ∈⇩∘ Vset β"
by (meson assms dghm_ObjMap_vsubset_Vset Vset_in_mono vsubset_in_VsetI)
lemma (in is_dghm) dghm_ArrMap_in_Vset:
assumes "α ∈⇩∘ β"
shows "𝔉⦇ArrMap⦈ ∈⇩∘ Vset β"
by (meson assms dghm_ArrMap_vsubset_Vset Vset_in_mono vsubset_in_VsetI)
lemma (in is_dghm) dghm_in_Vset:
assumes "𝒵 β" and "α ∈⇩∘ β"
shows "𝔉 ∈⇩∘ Vset β"
proof-
interpret β: 𝒵 β by (rule assms(1))
note [dg_cs_intros] =
dghm_ObjMap_in_Vset dghm_ArrMap_in_Vset HomDom.dg_in_Vset HomCod.dg_in_Vset
from assms(2) show ?thesis
by (subst dghm_def)
(cs_concl cs_simp: dg_cs_simps cs_intro: dg_cs_intros V_cs_intros)
qed
lemma (in is_dghm) dghm_is_dghm_if_ge_Limit:
assumes "𝒵 β" and "α ∈⇩∘ β"
shows "𝔉 : 𝔄 ↦↦⇩D⇩G⇘β⇙ 𝔅"
proof(rule is_dghmI)
from is_dghm_axioms assms show "digraph β 𝔄"
by (cs_concl cs_intro: digraph.dg_digraph_if_ge_Limit dg_cs_intros)
from is_dghm_axioms assms show "digraph β 𝔅"
by (cs_concl cs_intro: digraph.dg_digraph_if_ge_Limit dg_cs_intros)
qed (cs_concl cs_simp: dg_cs_simps cs_intro: assms(1) dg_cs_intros V_cs_intros dghm_ObjMap_vrange)+
lemma small_all_dghms[simp]: "small {𝔉. ∃𝔄 𝔅. 𝔉 : 𝔄 ↦↦⇩D⇩G⇘α⇙ 𝔅}"
proof(cases ‹𝒵 α›)
case True
from is_dghm.dghm_in_Vset show ?thesis
by (intro down[of _ ‹Vset (α + ω)›] subsetI)
(auto simp: True 𝒵.𝒵_Limit_αω 𝒵.𝒵_ω_αω 𝒵.intro 𝒵.𝒵_α_αω)
next
case False
then have "{𝔉. ∃𝔄 𝔅. 𝔉 : 𝔄 ↦↦⇩D⇩G⇘α⇙ 𝔅} = {}" by auto
then show ?thesis by simp
qed
lemma (in is_dghm) dghm_in_Vset_7: "𝔉 ∈⇩∘ Vset (α + 7⇩ℕ)"
proof-
note [folded VPow_iff, folded Vset_succ[OF Ord_α], dg_cs_intros] =
dghm_ObjMap_vsubset_Vset
dghm_ArrMap_vsubset_Vset
from HomDom.dg_digraph_in_Vset_4 have [dg_cs_intros]:
"𝔄 ∈⇩∘ Vset (succ (succ (succ (succ α))))"
by (succ_of_numeral) (cs_prems cs_simp: plus_V_succ_right V_cs_simps)
from HomCod.dg_digraph_in_Vset_4 have [dg_cs_intros]:
"𝔅 ∈⇩∘ Vset (succ (succ (succ (succ α))))"
by (succ_of_numeral) (cs_prems cs_simp: plus_V_succ_right V_cs_simps)
show ?thesis
by (subst dghm_def, succ_of_numeral)
(
cs_concl
cs_simp: plus_V_succ_right V_cs_simps dg_cs_simps
cs_intro: dg_cs_intros V_cs_intros
)
qed
lemma (in 𝒵) all_dghms_in_Vset:
assumes "𝒵 β" and "α ∈⇩∘ β"
shows "all_dghms α ∈⇩∘ Vset β"
proof(rule vsubset_in_VsetI)
interpret β: 𝒵 β by (rule assms(1))
show "all_dghms α ⊆⇩∘ Vset (α + 7⇩ℕ)"
proof(intro vsubsetI)
fix 𝔉 assume "𝔉 ∈⇩∘ all_dghms α"
then obtain 𝔄 𝔅 where 𝔉: "𝔉 : 𝔄 ↦↦⇩D⇩G⇘α⇙ 𝔅" by clarsimp
interpret is_dghm α 𝔄 𝔅 𝔉 using 𝔉 by simp
show "𝔉 ∈⇩∘ Vset (α + 7⇩ℕ)" by (rule dghm_in_Vset_7)
qed
from assms(2) show "Vset (α + 7⇩ℕ) ∈⇩∘ Vset β"
by (cs_concl cs_intro: V_cs_intros Ord_cs_intros)
qed
lemma small_dghms[simp]: "small {𝔉. 𝔉 : 𝔄 ↦↦⇩D⇩G⇘α⇙ 𝔅}"
by (rule down[of _ ‹set {𝔉. ∃𝔄 𝔅. 𝔉 : 𝔄 ↦↦⇩D⇩G⇘α⇙ 𝔅}›]) auto
text‹Further elementary properties.›
lemma (in is_dghm) dghm_is_arr_HomCod:
assumes "f : a ↦⇘𝔄⇙ b"
shows "𝔉⦇ArrMap⦈⦇f⦈ ∈⇩∘ 𝔅⦇Arr⦈" "𝔉⦇ObjMap⦈⦇a⦈ ∈⇩∘ 𝔅⦇Obj⦈" "𝔉⦇ObjMap⦈⦇b⦈ ∈⇩∘ 𝔅⦇Obj⦈"
using assms by (cs_concl cs_simp: dg_cs_simps cs_intro: dg_cs_intros)+
lemma (in is_dghm) dghm_vimage_dghm_ArrMap_vsubset_Hom:
assumes "a ∈⇩∘ 𝔄⦇Obj⦈" and "b ∈⇩∘ 𝔄⦇Obj⦈"
shows "𝔉⦇ArrMap⦈ `⇩∘ Hom 𝔄 a b ⊆⇩∘ Hom 𝔅 (𝔉⦇ObjMap⦈⦇a⦈) (𝔉⦇ObjMap⦈⦇b⦈)"
proof(intro vsubsetI)
fix g assume "g ∈⇩∘ 𝔉⦇ArrMap⦈ `⇩∘ Hom 𝔄 a b"
then obtain f where "f ∈⇩∘ Hom (𝔉⦇HomDom⦈) a b" and "g = 𝔉⦇ArrMap⦈⦇f⦈"
by (auto simp: dg_cs_simps)
then show "g ∈⇩∘ Hom 𝔅 (𝔉⦇ObjMap⦈⦇a⦈) (𝔉⦇ObjMap⦈⦇b⦈)"
by (simp add: dghm_ArrMap_is_arr dg_cs_simps)
qed
subsection‹Opposite digraph homomorphism›
subsubsection‹Definition and elementary properties›
text‹See Chapter II-2 in \cite{mac_lane_categories_2010}.›
definition op_dghm :: "V ⇒ V"
where "op_dghm 𝔉 =
[𝔉⦇ObjMap⦈, 𝔉⦇ArrMap⦈, op_dg (𝔉⦇HomDom⦈), op_dg (𝔉⦇HomCod⦈)]⇩∘"
text‹Components.›
lemma op_dghm_components[dg_op_simps]:
shows "op_dghm 𝔉⦇ObjMap⦈ = 𝔉⦇ObjMap⦈"
and "op_dghm 𝔉⦇ArrMap⦈ = 𝔉⦇ArrMap⦈"
and "op_dghm 𝔉⦇HomDom⦈ = op_dg (𝔉⦇HomDom⦈)"
and "op_dghm 𝔉⦇HomCod⦈ = op_dg (𝔉⦇HomCod⦈)"
unfolding op_dghm_def dghm_field_simps by (auto simp: nat_omega_simps)
subsubsection‹Further properties›
lemma (in is_dghm) is_dghm_op: "op_dghm 𝔉 : op_dg 𝔄 ↦↦⇩D⇩G⇘α⇙ op_dg 𝔅"
proof(intro is_dghmI, unfold dg_op_simps)
show "vfsequence (op_dghm 𝔉)" unfolding op_dghm_def by simp
show "vcard (op_dghm 𝔉) = 4⇩ℕ"
unfolding op_dghm_def by (auto simp: nat_omega_simps)
qed
(
cs_concl
cs_intro: dghm_ObjMap_vrange dg_cs_intros dg_op_intros V_cs_intros
cs_simp: dg_cs_simps dg_op_simps
)+
lemma (in is_dghm) is_dghm_op'[dg_op_intros]:
assumes "𝔄' = op_dg 𝔄" and "𝔅' = op_dg 𝔅" and "α' = α"
shows "op_dghm 𝔉 : 𝔄' ↦↦⇩D⇩G⇘α'⇙ 𝔅'"
unfolding assms by (rule is_dghm_op)
lemmas is_dghm_op[dg_op_intros] = is_dghm.is_dghm_op'
lemma (in is_dghm) dghm_op_dghm_op_dghm[dg_op_simps]: "op_dghm (op_dghm 𝔉) = 𝔉"
using is_dghm_axioms
by
(
cs_concl
cs_simp: dg_op_simps
cs_intro: dg_op_intros dghm_eqI[where 𝔉=𝔉]
)
lemmas dghm_op_dghm_op_dghm[dg_op_simps] = is_dghm.dghm_op_dghm_op_dghm
lemma eq_op_dghm_iff[dg_op_simps]:
assumes "𝔊 : 𝔄 ↦↦⇩D⇩G⇘α⇙ 𝔅" and "𝔉 : ℭ ↦↦⇩D⇩G⇘α⇙ 𝔇"
shows "op_dghm 𝔊 = op_dghm 𝔉 ⟷ 𝔊 = 𝔉"
proof
interpret L: is_dghm α 𝔄 𝔅 𝔊 by (rule assms(1))
interpret R: is_dghm α ℭ 𝔇 𝔉 by (rule assms(2))
assume prems: "op_dghm 𝔊 = op_dghm 𝔉"
show "𝔊 = 𝔉"
proof(rule dghm_eqI[OF assms])
from prems R.dghm_op_dghm_op_dghm L.dghm_op_dghm_op_dghm show
"𝔊⦇ObjMap⦈ = 𝔉⦇ObjMap⦈" and "𝔊⦇ArrMap⦈ = 𝔉⦇ArrMap⦈"
by metis+
from prems R.dghm_op_dghm_op_dghm L.dghm_op_dghm_op_dghm have
"𝔊⦇HomDom⦈ = 𝔉⦇HomDom⦈" "𝔊⦇HomCod⦈ = 𝔉⦇HomCod⦈"
by auto
then show "𝔄 = ℭ" "𝔅 = 𝔇" by (auto simp: dg_cs_simps)
qed
qed auto
subsection‹Composition of covariant digraph homomorphisms›
subsubsection‹Definition and elementary properties›
text‹See Chapter I-3 in \cite{mac_lane_categories_2010}.›
definition dghm_comp :: "V ⇒ V ⇒ V" (infixl ‹∘⇩D⇩G⇩H⇩M› 55)
where "𝔊 ∘⇩D⇩G⇩H⇩M 𝔉 =
[𝔊⦇ObjMap⦈ ∘⇩∘ 𝔉⦇ObjMap⦈, 𝔊⦇ArrMap⦈ ∘⇩∘ 𝔉⦇ArrMap⦈, 𝔉⦇HomDom⦈, 𝔊⦇HomCod⦈]⇩∘"
text‹Components.›
lemma dghm_comp_components:
shows "(𝔊 ∘⇩D⇩G⇩H⇩M 𝔉)⦇ObjMap⦈ = 𝔊⦇ObjMap⦈ ∘⇩∘ 𝔉⦇ObjMap⦈"
and "(𝔊 ∘⇩D⇩G⇩H⇩M 𝔉)⦇ArrMap⦈ = 𝔊⦇ArrMap⦈ ∘⇩∘ 𝔉⦇ArrMap⦈"
and [dg_shared_cs_simps, dg_cs_simps]: "(𝔊 ∘⇩D⇩G⇩H⇩M 𝔉)⦇HomDom⦈ = 𝔉⦇HomDom⦈"
and [dg_shared_cs_simps, dg_cs_simps]: "(𝔊 ∘⇩D⇩G⇩H⇩M 𝔉)⦇HomCod⦈ = 𝔊⦇HomCod⦈"
unfolding dghm_comp_def dghm_field_simps by (simp_all add: nat_omega_simps)
subsubsection‹Object map›
lemma dghm_comp_ObjMap_vsv[dg_cs_intros]:
assumes "𝔊 : 𝔅 ↦↦⇩D⇩G⇘α⇙ ℭ" and "𝔉 : 𝔄 ↦↦⇩D⇩G⇘α⇙ 𝔅"
shows "vsv ((𝔊 ∘⇩D⇩G⇩H⇩M 𝔉)⦇ObjMap⦈)"
proof-
interpret L: is_dghm α 𝔅 ℭ 𝔊 by (rule assms(1))
interpret R: is_dghm α 𝔄 𝔅 𝔉 by (rule assms(2))
show ?thesis by (cs_concl cs_simp: dghm_comp_components cs_intro: V_cs_intros)
qed
lemma dghm_comp_ObjMap_vdomain[dg_cs_simps]:
assumes "𝔊 : 𝔅 ↦↦⇩D⇩G⇘α⇙ ℭ" and "𝔉 : 𝔄 ↦↦⇩D⇩G⇘α⇙ 𝔅"
shows "𝒟⇩∘ ((𝔊 ∘⇩D⇩G⇩H⇩M 𝔉)⦇ObjMap⦈) = 𝔄⦇Obj⦈"
using assms
by
(
cs_concl
cs_simp: dghm_comp_components dg_cs_simps V_cs_simps
cs_intro: is_dghm.dghm_ObjMap_vrange
)
lemma dghm_comp_ObjMap_vrange:
assumes "𝔊 : 𝔅 ↦↦⇩D⇩G⇘α⇙ ℭ" and "𝔉 : 𝔄 ↦↦⇩D⇩G⇘α⇙ 𝔅"
shows "ℛ⇩∘ ((𝔊 ∘⇩D⇩G⇩H⇩M 𝔉)⦇ObjMap⦈) ⊆⇩∘ ℭ⦇Obj⦈"
using assms
by
(
cs_concl
cs_simp: dghm_comp_components
cs_intro: is_dghm.dghm_ObjMap_vrange V_cs_intros
)
lemma dghm_comp_ObjMap_app[dg_cs_simps]:
assumes "𝔊 : 𝔅 ↦↦⇩D⇩G⇘α⇙ ℭ" and "𝔉 : 𝔄 ↦↦⇩D⇩G⇘α⇙ 𝔅" and "a ∈⇩∘ 𝔄⦇Obj⦈"
shows "(𝔊 ∘⇩D⇩G⇩H⇩M 𝔉)⦇ObjMap⦈⦇a⦈ = 𝔊⦇ObjMap⦈⦇𝔉⦇ObjMap⦈⦇a⦈⦈"
proof-
interpret L: is_dghm α 𝔅 ℭ 𝔊 by (rule assms(1))
interpret R: is_dghm α 𝔄 𝔅 𝔉 by (rule assms(2))
from assms(3) show "(𝔊 ∘⇩D⇩G⇩H⇩M 𝔉)⦇ObjMap⦈⦇a⦈ = 𝔊⦇ObjMap⦈⦇𝔉⦇ObjMap⦈⦇a⦈⦈"
by
(
cs_concl
cs_simp: dghm_comp_components dg_cs_simps V_cs_simps
cs_intro: V_cs_intros dg_cs_intros
)
qed
subsubsection‹Arrow map›
lemma dghm_comp_ArrMap_vsv[dg_cs_intros]:
assumes "𝔊 : 𝔅 ↦↦⇩D⇩G⇘α⇙ ℭ" and "𝔉 : 𝔄 ↦↦⇩D⇩G⇘α⇙ 𝔅"
shows "vsv ((𝔊 ∘⇩D⇩G⇩H⇩M 𝔉)⦇ArrMap⦈)"
proof-
interpret L: is_dghm α 𝔅 ℭ 𝔊 by (rule assms(1))
interpret R: is_dghm α 𝔄 𝔅 𝔉 by (rule assms(2))
show ?thesis by (cs_concl cs_simp: dghm_comp_components cs_intro: V_cs_intros)
qed
lemma dghm_comp_ArrMap_vdomain[dg_cs_simps]:
assumes "𝔊 : 𝔅 ↦↦⇩D⇩G⇘α⇙ ℭ" and "𝔉 : 𝔄 ↦↦⇩D⇩G⇘α⇙ 𝔅"
shows "𝒟⇩∘ ((𝔊 ∘⇩D⇩G⇩H⇩M 𝔉)⦇ArrMap⦈) = 𝔄⦇Arr⦈"
using assms
by
(
cs_concl
cs_simp: dghm_comp_components dg_cs_simps V_cs_simps
cs_intro: is_dghm.dghm_ArrMap_vrange
)
lemma dghm_comp_ArrMap_vrange[dg_cs_intros]:
assumes "𝔊 : 𝔅 ↦↦⇩D⇩G⇘α⇙ ℭ" and "𝔉 : 𝔄 ↦↦⇩D⇩G⇘α⇙ 𝔅"
shows "ℛ⇩∘ ((𝔊 ∘⇩D⇩G⇩H⇩M 𝔉)⦇ArrMap⦈) ⊆⇩∘ ℭ⦇Arr⦈"
using assms
by
(
cs_concl
cs_simp: dghm_comp_components
cs_intro: is_dghm.dghm_ArrMap_vrange V_cs_intros
)
lemma dghm_comp_ArrMap_app[dg_cs_simps]:
assumes "𝔊 : 𝔅 ↦↦⇩D⇩G⇘α⇙ ℭ" and "𝔉 : 𝔄 ↦↦⇩D⇩G⇘α⇙ 𝔅" and "f ∈⇩∘ 𝔄⦇Arr⦈"
shows "(𝔊 ∘⇩D⇩G⇩H⇩M 𝔉)⦇ArrMap⦈⦇f⦈ = 𝔊⦇ArrMap⦈⦇𝔉⦇ArrMap⦈⦇f⦈⦈"
proof-
interpret L: is_dghm α 𝔅 ℭ 𝔊 by (rule assms(1))
interpret R: is_dghm α 𝔄 𝔅 𝔉 by (rule assms(2))
from assms(3) show "(𝔊 ∘⇩D⇩G⇩H⇩M 𝔉)⦇ArrMap⦈⦇f⦈ = 𝔊⦇ArrMap⦈⦇𝔉⦇ArrMap⦈⦇f⦈⦈"
by
(
cs_concl
cs_simp: dghm_comp_components dg_cs_simps V_cs_simps
cs_intro: V_cs_intros dg_cs_intros
)
qed
subsubsection‹Opposite of the composition of covariant digraph homomorphisms›
lemma op_dghm_dghm_comp[dg_op_simps]:
"op_dghm (𝔊 ∘⇩D⇩G⇩H⇩M 𝔉) = op_dghm 𝔊 ∘⇩D⇩G⇩H⇩M op_dghm 𝔉"
unfolding dghm_comp_def op_dghm_def dghm_field_simps
by (simp add: nat_omega_simps)
subsubsection‹Further properties›
lemma dghm_comp_is_dghm[dg_cs_intros]:
assumes "𝔊 : 𝔅 ↦↦⇩D⇩G⇘α⇙ ℭ" and "𝔉 : 𝔄 ↦↦⇩D⇩G⇘α⇙ 𝔅"
shows "𝔊 ∘⇩D⇩G⇩H⇩M 𝔉 : 𝔄 ↦↦⇩D⇩G⇘α⇙ ℭ"
proof-
interpret L: is_dghm α 𝔅 ℭ 𝔊 by (rule assms(1))
interpret R: is_dghm α 𝔄 𝔅 𝔉 by (rule assms(2))
show ?thesis
proof(intro is_dghmI is_dghmI, unfold dg_cs_simps)
show "vfsequence (𝔊 ∘⇩D⇩G⇩H⇩M 𝔉)" unfolding dghm_comp_def by simp
show "vcard (𝔊 ∘⇩D⇩G⇩H⇩M 𝔉) = 4⇩ℕ"
unfolding dghm_comp_def by (simp add: nat_omega_simps)
fix f a b assume "f : a ↦⇘𝔄⇙ b"
with assms show "(𝔊 ∘⇩D⇩G⇩H⇩M 𝔉)⦇ArrMap⦈⦇f⦈ :
(𝔊 ∘⇩D⇩G⇩H⇩M 𝔉)⦇ObjMap⦈⦇a⦈ ↦⇘ℭ⇙ (𝔊 ∘⇩D⇩G⇩H⇩M 𝔉)⦇ObjMap⦈⦇b⦈"
by (cs_concl cs_simp: dg_cs_simps cs_intro: dg_cs_intros)
qed
(
use assms in
‹
cs_concl
cs_intro: dg_cs_intros dghm_comp_ObjMap_vrange
cs_simp: dg_cs_simps
›
)+
qed
lemma dghm_comp_assoc[dg_cs_simps]:
assumes "ℌ : ℭ ↦↦⇩D⇩G⇘α⇙ 𝔇" and "𝔊 : 𝔅 ↦↦⇩D⇩G⇘α⇙ ℭ" and "𝔉 : 𝔄 ↦↦⇩D⇩G⇘α⇙ 𝔅"
shows "(ℌ ∘⇩D⇩G⇩H⇩M 𝔊) ∘⇩D⇩G⇩H⇩M 𝔉 = ℌ ∘⇩D⇩G⇩H⇩M (𝔊 ∘⇩D⇩G⇩H⇩M 𝔉)"
proof(rule dghm_eqI [of α 𝔄 𝔇 _ 𝔄 𝔇])
show "(ℌ ∘⇩D⇩G⇩H⇩M 𝔊 ∘⇩D⇩G⇩H⇩M 𝔉)⦇ObjMap⦈ = (ℌ ∘⇩D⇩G⇩H⇩M (𝔊 ∘⇩D⇩G⇩H⇩M 𝔉))⦇ObjMap⦈"
proof(rule vsv_eqI)
show "(ℌ ∘⇩D⇩G⇩H⇩M 𝔊 ∘⇩D⇩G⇩H⇩M 𝔉)⦇ObjMap⦈⦇a⦈ = (ℌ ∘⇩D⇩G⇩H⇩M (𝔊 ∘⇩D⇩G⇩H⇩M 𝔉))⦇ObjMap⦈⦇a⦈"
if "a ∈⇩∘ 𝒟⇩∘ ((ℌ ∘⇩D⇩G⇩H⇩M 𝔊 ∘⇩D⇩G⇩H⇩M 𝔉)⦇ObjMap⦈)" for a
using that assms
by
(cs_prems cs_simp: dg_cs_simps cs_intro: dg_cs_intros)
(cs_concl cs_simp: dg_cs_simps cs_intro: dg_cs_intros)
qed (use assms in ‹cs_concl cs_simp: dg_cs_simps cs_intro: dg_cs_intros›)+
show "(ℌ ∘⇩D⇩G⇩H⇩M 𝔊 ∘⇩D⇩G⇩H⇩M 𝔉)⦇ArrMap⦈ = (ℌ ∘⇩D⇩G⇩H⇩M (𝔊 ∘⇩D⇩G⇩H⇩M 𝔉))⦇ArrMap⦈"
proof(rule vsv_eqI)
show "(ℌ ∘⇩D⇩G⇩H⇩M 𝔊 ∘⇩D⇩G⇩H⇩M 𝔉)⦇ArrMap⦈⦇a⦈ = (ℌ ∘⇩D⇩G⇩H⇩M (𝔊 ∘⇩D⇩G⇩H⇩M 𝔉))⦇ArrMap⦈⦇a⦈"
if "a ∈⇩∘ 𝒟⇩∘ ((ℌ ∘⇩D⇩G⇩H⇩M 𝔊 ∘⇩D⇩G⇩H⇩M 𝔉)⦇ArrMap⦈)" for a
using that assms
by
(cs_prems cs_simp: dg_cs_simps cs_intro: dg_cs_intros)
(cs_concl cs_simp: dg_cs_simps cs_intro: dg_cs_intros)
qed (use assms in ‹cs_concl cs_simp: dg_cs_simps cs_intro: dg_cs_intros›)+
qed (use assms in ‹cs_concl cs_intro: dg_cs_intros›)+
subsection‹Composition of contravariant digraph homomorphisms›
subsubsection‹Definition and elementary properties›
text‹See section 1.2 in \cite{bodo_categories_1970}.›
definition dghm_cn_comp :: "V ⇒ V ⇒ V" (infixl ‹⇩D⇩G⇩H⇩M∘› 55)
where "𝔊 ⇩D⇩G⇩H⇩M∘ 𝔉 =
[
𝔊⦇ObjMap⦈ ∘⇩∘ 𝔉⦇ObjMap⦈,
𝔊⦇ArrMap⦈ ∘⇩∘ 𝔉⦇ArrMap⦈,
op_dg (𝔉⦇HomDom⦈),
𝔊⦇HomCod⦈
]⇩∘"
text‹Components.›
lemma dghm_cn_comp_components:
shows "(𝔊 ⇩D⇩G⇩H⇩M∘ 𝔉)⦇ObjMap⦈ = 𝔊⦇ObjMap⦈ ∘⇩∘ 𝔉⦇ObjMap⦈"
and "(𝔊 ⇩D⇩G⇩H⇩M∘ 𝔉)⦇ArrMap⦈ = 𝔊⦇ArrMap⦈ ∘⇩∘ 𝔉⦇ArrMap⦈"
and [dg_cn_cs_simps]: "(𝔊 ⇩D⇩G⇩H⇩M∘ 𝔉)⦇HomDom⦈ = op_dg (𝔉⦇HomDom⦈)"
and [dg_cn_cs_simps]: "(𝔊 ⇩D⇩G⇩H⇩M∘ 𝔉)⦇HomCod⦈ = 𝔊⦇HomCod⦈"
unfolding dghm_cn_comp_def dghm_field_simps by (simp_all add: nat_omega_simps)
subsubsection‹Object map: two contravariant digraph homomorphisms›
lemma dghm_cn_comp_ObjMap_vsv[dg_cn_cs_intros]:
assumes "𝔊 : 𝔅 ⇩D⇩G↦↦⇘α⇙ ℭ" and "𝔉 : 𝔄 ⇩D⇩G↦↦⇘α⇙ 𝔅"
shows "vsv ((𝔊 ⇩D⇩G⇩H⇩M∘ 𝔉)⦇ObjMap⦈)"
proof-
interpret L: is_dghm α ‹op_dg 𝔅› ℭ 𝔊 by (rule assms(1))
interpret R: is_dghm α ‹op_dg 𝔄› 𝔅 𝔉 by (rule assms(2))
show ?thesis
by (cs_concl cs_simp: dghm_cn_comp_components cs_intro: V_cs_intros)
qed
lemma dghm_cn_comp_ObjMap_vdomain[dg_cn_cs_simps]:
assumes "𝔊 : 𝔅 ⇩D⇩G↦↦⇘α⇙ ℭ" and "𝔉 : 𝔄 ⇩D⇩G↦↦⇘α⇙ 𝔅"
shows "𝒟⇩∘ ((𝔊 ⇩D⇩G⇩H⇩M∘ 𝔉)⦇ObjMap⦈) = 𝔄⦇Obj⦈"
using assms
by
(
cs_concl
cs_simp: dghm_cn_comp_components dg_cs_simps dg_op_simps V_cs_simps
cs_intro: is_dghm.dghm_ObjMap_vrange
)
lemma dghm_cn_comp_ObjMap_vrange:
assumes "𝔊 : 𝔅 ⇩D⇩G↦↦⇘α⇙ ℭ" and "𝔉 : 𝔄 ⇩D⇩G↦↦⇘α⇙ 𝔅"
shows "ℛ⇩∘ ((𝔊 ⇩D⇩G⇩H⇩M∘ 𝔉)⦇ObjMap⦈) ⊆⇩∘ ℭ⦇Obj⦈"
using assms
by
(
cs_concl
cs_simp: dghm_cn_comp_components
cs_intro: is_dghm.dghm_ObjMap_vrange V_cs_intros
)
lemma dghm_cn_comp_ObjMap_app[dg_cn_cs_simps]:
assumes "𝔊 : 𝔅 ⇩D⇩G↦↦⇘α⇙ ℭ" and "𝔉 : 𝔄 ⇩D⇩G↦↦⇘α⇙ 𝔅" and "a ∈⇩∘ 𝔄⦇Obj⦈"
shows "(𝔊 ⇩D⇩G⇩H⇩M∘ 𝔉)⦇ObjMap⦈⦇a⦈ = 𝔊⦇ObjMap⦈⦇𝔉⦇ObjMap⦈⦇a⦈⦈"
proof-
interpret L: is_dghm α ‹op_dg 𝔅› ℭ 𝔊 by (rule assms(1))
interpret R: is_dghm α ‹op_dg 𝔄› 𝔅 𝔉 by (rule assms(2))
from assms(3) show "(𝔊 ⇩D⇩G⇩H⇩M∘ 𝔉)⦇ObjMap⦈⦇a⦈ = 𝔊⦇ObjMap⦈⦇𝔉⦇ObjMap⦈⦇a⦈⦈"
by
(
cs_concl
cs_simp: dghm_cn_comp_components dg_cs_simps dg_op_simps V_cs_simps
cs_intro: V_cs_intros dg_cs_intros
)
qed
subsubsection‹Arrow map: two contravariant digraph homomorphisms›
lemma dghm_cn_comp_ArrMap_vsv[dg_cn_cs_intros]:
assumes "𝔊 : 𝔅 ⇩D⇩G↦↦⇘α⇙ ℭ" and "𝔉 : 𝔄 ⇩D⇩G↦↦⇘α⇙ 𝔅"
shows "vsv ((𝔊 ⇩D⇩G⇩H⇩M∘ 𝔉)⦇ArrMap⦈)"
proof-
interpret L: is_dghm α ‹op_dg 𝔅› ℭ 𝔊 by (rule assms(1))
interpret R: is_dghm α ‹op_dg 𝔄› 𝔅 𝔉 by (rule assms(2))
show ?thesis
by (cs_concl cs_simp: dghm_cn_comp_components cs_intro: V_cs_intros)
qed
lemma dghm_cn_comp_ArrMap_vdomain[dg_cs_simps]:
assumes "𝔊 : 𝔅 ⇩D⇩G↦↦⇘α⇙ ℭ" and "𝔉 : 𝔄 ⇩D⇩G↦↦⇘α⇙ 𝔅"
shows "𝒟⇩∘ ((𝔊 ⇩D⇩G⇩H⇩M∘ 𝔉)⦇ArrMap⦈) = 𝔄⦇Arr⦈"
using assms
by
(
cs_concl
cs_simp: dghm_cn_comp_components dg_cs_simps dg_op_simps V_cs_simps
cs_intro: is_dghm.dghm_ArrMap_vrange
)
lemma dghm_cn_comp_ArrMap_vrange:
assumes "𝔊 : 𝔅 ⇩D⇩G↦↦⇘α⇙ ℭ" and "𝔉 : 𝔄 ⇩D⇩G↦↦⇘α⇙ 𝔅"
shows "ℛ⇩∘ ((𝔊 ⇩D⇩G⇩H⇩M∘ 𝔉)⦇ArrMap⦈) ⊆⇩∘ ℭ⦇Arr⦈"
using assms
by
(
cs_concl
cs_simp: dghm_cn_comp_components
cs_intro: is_dghm.dghm_ArrMap_vrange V_cs_intros
)
lemma dghm_cn_comp_ArrMap_app[dg_cn_cs_simps]:
assumes "𝔊 : 𝔅 ⇩D⇩G↦↦⇘α⇙ ℭ" and "𝔉 : 𝔄 ⇩D⇩G↦↦⇘α⇙ 𝔅" and "a ∈⇩∘ 𝔄⦇Arr⦈"
shows "(𝔊 ⇩D⇩G⇩H⇩M∘ 𝔉)⦇ArrMap⦈⦇a⦈ = 𝔊⦇ArrMap⦈⦇𝔉⦇ArrMap⦈⦇a⦈⦈"
proof-
interpret L: is_dghm α ‹op_dg 𝔅› ℭ 𝔊 by (rule assms(1))
interpret R: is_dghm α ‹op_dg 𝔄› 𝔅 𝔉 by (rule assms(2))
from assms(3) show "(𝔊 ⇩D⇩G⇩H⇩M∘ 𝔉)⦇ArrMap⦈⦇a⦈ = 𝔊⦇ArrMap⦈⦇𝔉⦇ArrMap⦈⦇a⦈⦈"
by
(
cs_concl
cs_simp: dghm_cn_comp_components dg_cs_simps dg_op_simps V_cs_simps
cs_intro: V_cs_intros dg_cs_intros
)
qed
subsubsection‹Object map: contravariant and covariant digraph homomorphisms›
lemma dghm_cn_cov_comp_ObjMap_vsv[dg_cn_cs_intros]:
assumes "𝔊 : 𝔅 ⇩D⇩G↦↦⇘α⇙ ℭ" and "𝔉 : 𝔄 ↦↦⇩D⇩G⇘α⇙ 𝔅"
shows "vsv ((𝔊 ⇩D⇩G⇩H⇩M∘ 𝔉)⦇ObjMap⦈)"
proof-
interpret L: is_dghm α ‹op_dg 𝔅› ℭ 𝔊 by (rule assms(1))
interpret R: is_dghm α 𝔄 𝔅 𝔉 by (rule assms(2))
show ?thesis
by (cs_concl cs_simp: dghm_cn_comp_components cs_intro: V_cs_intros)
qed
lemma dghm_cn_cov_comp_ObjMap_vdomain[dg_cn_cs_simps]:
assumes "𝔊 : 𝔅 ⇩D⇩G↦↦⇘α⇙ ℭ" and "𝔉 : 𝔄 ↦↦⇩D⇩G⇘α⇙ 𝔅"
shows "𝒟⇩∘ ((𝔊 ⇩D⇩G⇩H⇩M∘ 𝔉)⦇ObjMap⦈) = 𝔄⦇Obj⦈"
using assms
by
(
cs_concl
cs_simp: dghm_cn_comp_components dg_cs_simps dg_op_simps V_cs_simps
cs_intro: is_dghm.dghm_ObjMap_vrange
)
lemma dghm_cn_cov_comp_ObjMap_vrange:
assumes "𝔊 : 𝔅 ⇩D⇩G↦↦⇘α⇙ ℭ" and "𝔉 : 𝔄 ↦↦⇩D⇩G⇘α⇙ 𝔅"
shows "ℛ⇩∘ ((𝔊 ⇩D⇩G⇩H⇩M∘ 𝔉)⦇ObjMap⦈) ⊆⇩∘ ℭ⦇Obj⦈"
using assms
by
(
cs_concl
cs_simp: dghm_cn_comp_components
cs_intro: is_dghm.dghm_ObjMap_vrange V_cs_intros
)
lemma dghm_cn_cov_comp_ObjMap_app[dg_cn_cs_simps]:
assumes "𝔊 : 𝔅 ⇩D⇩G↦↦⇘α⇙ ℭ" and "𝔉 : 𝔄 ↦↦⇩D⇩G⇘α⇙ 𝔅" and "a ∈⇩∘ 𝔄⦇Obj⦈"
shows "(𝔊 ⇩D⇩G⇩H⇩M∘ 𝔉)⦇ObjMap⦈⦇a⦈ = 𝔊⦇ObjMap⦈⦇𝔉⦇ObjMap⦈⦇a⦈⦈"
proof-
interpret L: is_dghm α ‹op_dg 𝔅› ℭ 𝔊 by (rule assms(1))
interpret R: is_dghm α 𝔄 𝔅 𝔉 by (rule assms(2))
from assms show "(𝔊 ⇩D⇩G⇩H⇩M∘ 𝔉)⦇ObjMap⦈⦇a⦈ = 𝔊⦇ObjMap⦈⦇𝔉⦇ObjMap⦈⦇a⦈⦈"
by
(
cs_concl
cs_simp: dghm_cn_comp_components dg_cs_simps V_cs_simps
cs_intro: V_cs_intros dg_op_intros dg_cs_intros
)
qed
subsubsection‹Arrow map: contravariant and covariant digraph homomorphisms›
lemma dghm_cn_cov_comp_ArrMap_vsv[dg_cn_cs_intros]:
assumes "𝔊 : 𝔅 ⇩D⇩G↦↦⇘α⇙ ℭ" and "𝔉 : 𝔄 ↦↦⇩D⇩G⇘α⇙ 𝔅"
shows "vsv ((𝔊 ⇩D⇩G⇩H⇩M∘ 𝔉)⦇ArrMap⦈)"
proof-
interpret L: is_dghm α ‹op_dg 𝔅› ℭ 𝔊 by (rule assms(1))
interpret R: is_dghm α 𝔄 𝔅 𝔉 by (rule assms(2))
show ?thesis
by (cs_concl cs_simp: dghm_cn_comp_components cs_intro: V_cs_intros)
qed
lemma dghm_cn_cov_comp_ArrMap_vdomain[dg_cn_cs_simps]:
assumes "𝔊 : 𝔅 ⇩D⇩G↦↦⇘α⇙ ℭ" and "𝔉 : 𝔄 ↦↦⇩D⇩G⇘α⇙ 𝔅"
shows "𝒟⇩∘ ((𝔊 ⇩D⇩G⇩H⇩M∘ 𝔉)⦇ArrMap⦈) = 𝔄⦇Arr⦈"
using assms
by
(
cs_concl
cs_simp: dghm_cn_comp_components dg_cs_simps dg_op_simps V_cs_simps
cs_intro: is_dghm.dghm_ArrMap_vrange
)
lemma dghm_cn_cov_comp_ArrMap_vrange:
assumes "𝔊 : 𝔅 ⇩D⇩G↦↦⇘α⇙ ℭ" and "𝔉 : 𝔄 ↦↦⇩D⇩G⇘α⇙ 𝔅"
shows "ℛ⇩∘ ((𝔊 ⇩D⇩G⇩H⇩M∘ 𝔉)⦇ArrMap⦈) ⊆⇩∘ ℭ⦇Arr⦈"
using assms
by
(
cs_concl
cs_simp: dghm_cn_comp_components
cs_intro: is_dghm.dghm_ArrMap_vrange V_cs_intros
)
lemma dghm_cn_cov_comp_ArrMap_app[dg_cn_cs_simps]:
assumes "𝔊 : 𝔅 ⇩D⇩G↦↦⇘α⇙ ℭ" and "𝔉 : 𝔄 ↦↦⇩D⇩G⇘α⇙ 𝔅" and "a ∈⇩∘ 𝔄⦇Arr⦈"
shows "(𝔊 ⇩D⇩G⇩H⇩M∘ 𝔉)⦇ArrMap⦈⦇a⦈ = 𝔊⦇ArrMap⦈⦇𝔉⦇ArrMap⦈⦇a⦈⦈"
proof-
interpret L: is_dghm α ‹op_dg 𝔅› ℭ 𝔊 by (rule assms(1))
interpret R: is_dghm α 𝔄 𝔅 𝔉 by (rule assms(2))
from assms(3) show "(𝔊 ⇩D⇩G⇩H⇩M∘ 𝔉)⦇ArrMap⦈⦇a⦈ = 𝔊⦇ArrMap⦈⦇𝔉⦇ArrMap⦈⦇a⦈⦈"
by
(
cs_concl
cs_simp: dghm_cn_comp_components dg_cs_simps V_cs_simps
cs_intro: V_cs_intros dg_op_intros dg_cs_intros
)
qed
subsubsection‹
Opposite of the contravariant composition of the digraph homomorphisms
›
lemma op_dghm_dghm_cn_comp[dg_op_simps]:
"op_dghm (𝔊 ⇩D⇩G⇩H⇩M∘ 𝔉) = op_dghm 𝔊 ⇩D⇩G⇩H⇩M∘ op_dghm 𝔉"
unfolding op_dghm_def dghm_cn_comp_def dghm_field_simps
by (auto simp: nat_omega_simps)
subsubsection‹Further properties›
lemma dghm_cn_comp_is_dghm[dg_cn_cs_intros]:
assumes "digraph α 𝔄" and "𝔊 : 𝔅 ⇩D⇩G↦↦⇘α⇙ ℭ" and "𝔉 : 𝔄 ⇩D⇩G↦↦⇘α⇙ 𝔅"
shows "𝔊 ⇩D⇩G⇩H⇩M∘ 𝔉 : 𝔄 ↦↦⇩D⇩G⇘α⇙ ℭ"
proof-
interpret 𝔄: digraph α 𝔄 by (rule assms(1))
interpret L: is_dghm α ‹op_dg 𝔅› ℭ 𝔊 using assms(2) by auto
interpret R: is_dghm α ‹op_dg 𝔄› 𝔅 𝔉 using assms(3) by auto
show ?thesis
proof(intro is_dghmI, unfold dg_op_simps dg_cs_simps dg_cn_cs_simps)
show "vfsequence (𝔊 ⇩D⇩G⇩H⇩M∘ 𝔉)" unfolding dghm_cn_comp_def by auto
show "vcard (𝔊 ⇩D⇩G⇩H⇩M∘ 𝔉) = 4⇩ℕ"
unfolding dghm_cn_comp_def by (simp add: nat_omega_simps)
fix f a b assume "f : a ↦⇘𝔄⇙ b"
with assms show "(𝔊 ⇩D⇩G⇩H⇩M∘ 𝔉)⦇ArrMap⦈⦇f⦈ :
(𝔊 ⇩D⇩G⇩H⇩M∘ 𝔉)⦇ObjMap⦈⦇a⦈ ↦⇘ℭ⇙ (𝔊 ⇩D⇩G⇩H⇩M∘ 𝔉)⦇ObjMap⦈⦇b⦈"
by
(
cs_concl
cs_simp: dg_cn_cs_simps
cs_intro: dg_cs_intros dg_op_intros
)
qed
(
cs_concl
cs_simp: dg_cs_simps dg_cn_cs_simps
cs_intro: dghm_cn_comp_ObjMap_vrange dg_cs_intros dg_cn_cs_intros
)+
qed
lemma dghm_cn_cov_comp_is_dghm[dg_cn_cs_intros]:
assumes "𝔊 : 𝔅 ⇩D⇩G↦↦⇘α⇙ ℭ" and "𝔉 : 𝔄 ↦↦⇩D⇩G⇘α⇙ 𝔅"
shows "𝔊 ⇩D⇩G⇩H⇩M∘ 𝔉 : 𝔄 ⇩D⇩G↦↦⇘α⇙ ℭ"
proof-
interpret L: is_dghm α ‹op_dg 𝔅› ℭ 𝔊 by (rule assms(1))
interpret R: is_dghm α 𝔄 𝔅 𝔉 by (rule assms(2))
show ?thesis
proof(intro is_dghmI, unfold dg_op_simps dg_cs_simps)
show "vfsequence (𝔊 ⇩D⇩G⇩H⇩M∘ 𝔉)" unfolding dghm_cn_comp_def by simp
show "vcard (𝔊 ⇩D⇩G⇩H⇩M∘ 𝔉) = 4⇩ℕ"
unfolding dghm_cn_comp_def by (auto simp: nat_omega_simps)
fix f b a assume "f : b ↦⇘𝔄⇙ a"
with assms show "(𝔊 ⇩D⇩G⇩H⇩M∘ 𝔉)⦇ArrMap⦈⦇f⦈ :
(𝔊 ⇩D⇩G⇩H⇩M∘ 𝔉)⦇ObjMap⦈⦇a⦈ ↦⇘ℭ⇙ (𝔊 ⇩D⇩G⇩H⇩M∘ 𝔉)⦇ObjMap⦈⦇b⦈"
by (cs_concl cs_simp: dg_cn_cs_simps dg_op_simps cs_intro: dg_cs_intros)
qed
(
cs_concl
cs_simp: dg_cs_simps dg_cn_cs_simps
cs_intro:
dghm_cn_cov_comp_ObjMap_vrange
dg_cs_intros dg_cn_cs_intros dg_op_intros
)+
qed
lemma dghm_cov_cn_comp_is_dghm:
assumes "𝔊 : 𝔅 ↦↦⇩D⇩G⇘α⇙ ℭ" and "𝔉 : 𝔄 ⇩D⇩G↦↦⇘α⇙ 𝔅"
shows "𝔊 ∘⇩D⇩G⇩H⇩M 𝔉 : 𝔄 ⇩D⇩G↦↦⇘α⇙ ℭ"
using assms by (rule dghm_comp_is_dghm)
subsection‹Identity digraph homomorphism›
subsubsection‹Definition and elementary properties›
text‹See Chapter I-3 in \cite{mac_lane_categories_2010}.›
definition dghm_id :: "V ⇒ V"
where "dghm_id ℭ = [vid_on (ℭ⦇Obj⦈), vid_on (ℭ⦇Arr⦈), ℭ, ℭ]⇩∘"
text‹Components.›
lemma dghm_id_components:
shows "dghm_id ℭ⦇ObjMap⦈ = vid_on (ℭ⦇Obj⦈)"
and "dghm_id ℭ⦇ArrMap⦈ = vid_on (ℭ⦇Arr⦈)"
and [dg_shared_cs_simps, dg_cs_simps]: "dghm_id ℭ⦇HomDom⦈ = ℭ"
and [dg_shared_cs_simps, dg_cs_simps]: "dghm_id ℭ⦇HomCod⦈ = ℭ"
unfolding dghm_id_def dghm_field_simps by (simp_all add: nat_omega_simps)
subsubsection‹Object map›
mk_VLambda dghm_id_components(1)[folded VLambda_vid_on]
|vsv dghm_id_ObjMap_vsv[dg_shared_cs_intros, dg_cs_intros]|
|vdomain dghm_id_ObjMap_vdomain[dg_shared_cs_simps, dg_cs_simps]|
|app dghm_id_ObjMap_app[dg_shared_cs_simps, dg_cs_simps]|
lemma dghm_id_ObjMap_vrange[dg_shared_cs_simps, dg_cs_simps]:
"ℛ⇩∘ (dghm_id ℭ⦇ObjMap⦈) = ℭ⦇Obj⦈"
unfolding dghm_id_components by simp
subsubsection‹Arrow map›
mk_VLambda dghm_id_components(2)[folded VLambda_vid_on]
|vsv dghm_id_ArrMap_vsv[dg_shared_cs_intros, dg_cs_intros]|
|vdomain dghm_id_ArrMap_vdomain[dg_shared_cs_simps, dg_cs_simps]|
|app dghm_id_ArrMap_app[dg_shared_cs_simps, dg_cs_simps]|
lemma dghm_id_ArrMap_vrange[dg_shared_cs_simps, dg_cs_simps]:
"ℛ⇩∘ (dghm_id ℭ⦇ArrMap⦈) = ℭ⦇Arr⦈"
unfolding dghm_id_components by simp
subsubsection‹Opposite identity digraph homomorphism›
lemma op_dghm_dghm_id[dg_op_simps]: "op_dghm (dghm_id ℭ) = dghm_id (op_dg ℭ)"
unfolding dghm_id_def op_dg_def op_dghm_def dghm_field_simps dg_field_simps
by (auto simp: nat_omega_simps)
subsubsection‹An identity digraph homomorphism is a digraph homomorphism›
lemma (in digraph) dg_dghm_id_is_dghm: "dghm_id ℭ : ℭ ↦↦⇩D⇩G⇘α⇙ ℭ"
proof(intro is_dghmI, unfold dg_cs_simps)
show "vfsequence (dghm_id ℭ)" unfolding dghm_id_def by simp
show "vcard (dghm_id ℭ) = 4⇩ℕ"
unfolding dghm_id_def by (simp add: nat_omega_simps)
qed (cs_concl cs_simp: dg_cs_simps cs_intro: dg_cs_intros V_cs_intros)+
lemma (in digraph) dg_dghm_id_is_dghm':
assumes "𝔄 = ℭ" and "𝔅 = ℭ"
shows "dghm_id ℭ : 𝔄 ↦↦⇩D⇩G⇘α⇙ 𝔅"
unfolding assms by (rule dg_dghm_id_is_dghm)
lemmas [dg_cs_intros] = digraph.dg_dghm_id_is_dghm'
subsubsection‹Further properties›
lemma (in is_dghm) dghm_dghm_comp_dghm_id_left: "dghm_id 𝔅 ∘⇩D⇩G⇩H⇩M 𝔉 = 𝔉"
proof(rule dghm_eqI [of α 𝔄 𝔅 _ 𝔄 𝔅])
show "(dghm_id 𝔅 ∘⇩D⇩G⇩H⇩M 𝔉)⦇ObjMap⦈ = 𝔉⦇ObjMap⦈"
proof(rule vsv_eqI)
show "(dghm_id 𝔅 ∘⇩D⇩G⇩H⇩M 𝔉)⦇ObjMap⦈⦇a⦈ = 𝔉⦇ObjMap⦈⦇a⦈"
if "a ∈⇩∘ 𝒟⇩∘ ((dghm_id 𝔅 ∘⇩D⇩G⇩H⇩M 𝔉)⦇ObjMap⦈)" for a
using that
by
(cs_prems cs_simp: dg_cs_simps cs_intro: dg_cs_intros)
(cs_concl cs_simp: dg_cs_simps cs_intro: dg_cs_intros)
qed (cs_concl cs_simp: dg_cs_simps cs_intro: dg_cs_intros V_cs_intros)+
show "(dghm_id 𝔅 ∘⇩D⇩G⇩H⇩M 𝔉)⦇ArrMap⦈ = 𝔉⦇ArrMap⦈"
proof(rule vsv_eqI)
show "(dghm_id 𝔅 ∘⇩D⇩G⇩H⇩M 𝔉)⦇ArrMap⦈⦇a⦈ = 𝔉⦇ArrMap⦈⦇a⦈"
if "a ∈⇩∘ 𝒟⇩∘ ((dghm_id 𝔅 ∘⇩D⇩G⇩H⇩M 𝔉)⦇ArrMap⦈)" for a
using that
by
(cs_prems cs_simp: dg_cs_simps cs_intro: dg_cs_intros)
(cs_concl cs_simp: dg_cs_simps cs_intro: dg_cs_intros)
qed (cs_concl cs_simp: dg_cs_simps cs_intro: dg_cs_intros V_cs_intros)+
qed (cs_concl cs_simp: cs_intro: dg_cs_intros)+
lemmas [dg_cs_simps] = is_dghm.dghm_dghm_comp_dghm_id_left
lemma (in is_dghm) dghm_dghm_comp_dghm_id_right: "𝔉 ∘⇩D⇩G⇩H⇩M dghm_id 𝔄 = 𝔉"
proof(rule dghm_eqI [of α 𝔄 𝔅 _ 𝔄 𝔅])
show "(𝔉 ∘⇩D⇩G⇩H⇩M dghm_id 𝔄)⦇ObjMap⦈ = 𝔉⦇ObjMap⦈"
proof(rule vsv_eqI)
show "(𝔉 ∘⇩D⇩G⇩H⇩M dghm_id 𝔄)⦇ObjMap⦈⦇a⦈ = 𝔉⦇ObjMap⦈⦇a⦈"
if "a ∈⇩∘ 𝒟⇩∘ ((𝔉 ∘⇩D⇩G⇩H⇩M dghm_id 𝔄)⦇ObjMap⦈)" for a
using that
by
(cs_prems cs_simp: dg_cs_simps cs_intro: dg_cs_intros)
(cs_concl cs_simp: dg_cs_simps cs_intro: dg_cs_intros)
qed (cs_concl cs_simp: dg_cs_simps cs_intro: dg_cs_intros V_cs_intros)+
show "(𝔉 ∘⇩D⇩G⇩H⇩M dghm_id 𝔄)⦇ArrMap⦈ = 𝔉⦇ArrMap⦈"
proof(rule vsv_eqI)
show "(𝔉 ∘⇩D⇩G⇩H⇩M dghm_id 𝔄)⦇ArrMap⦈⦇a⦈ = 𝔉⦇ArrMap⦈⦇a⦈"
if "a ∈⇩∘ 𝒟⇩∘ ((𝔉 ∘⇩D⇩G⇩H⇩M dghm_id 𝔄)⦇ArrMap⦈)" for a
using that
by
(cs_prems cs_simp: dg_cs_simps cs_intro: dg_cs_intros)
(cs_concl cs_simp: dg_cs_simps cs_intro: dg_cs_intros)
qed (cs_concl cs_simp: dg_cs_simps cs_intro: dg_cs_intros V_cs_intros)+
qed (cs_concl cs_simp: dg_cs_simps cs_intro: dg_cs_intros)+
lemmas [dg_cs_simps] = is_dghm.dghm_dghm_comp_dghm_id_right
subsection‹Constant digraph homomorphism›
subsubsection‹Definition and elementary properties›
text‹See Chapter III-3 in \cite{mac_lane_categories_2010}.›
definition dghm_const :: "V ⇒ V ⇒ V ⇒ V ⇒ V"
where "dghm_const ℭ 𝔇 a f =
[vconst_on (ℭ⦇Obj⦈) a, vconst_on (ℭ⦇Arr⦈) f, ℭ, 𝔇]⇩∘"
text‹Components.›
lemma dghm_const_components:
shows "dghm_const ℭ 𝔇 a f⦇ObjMap⦈ = vconst_on (ℭ⦇Obj⦈) a"
and "dghm_const ℭ 𝔇 a f⦇ArrMap⦈ = vconst_on (ℭ⦇Arr⦈) f"
and [dg_shared_cs_simps, dg_cs_simps]: "dghm_const ℭ 𝔇 a f⦇HomDom⦈ = ℭ"
and [dg_shared_cs_simps, dg_cs_simps]: "dghm_const ℭ 𝔇 a f⦇HomCod⦈ = 𝔇"
unfolding dghm_const_def dghm_field_simps by (simp_all add: nat_omega_simps)
subsubsection‹Object map›
mk_VLambda dghm_const_components(1)[folded VLambda_vconst_on]
|vsv dghm_const_ObjMap_vsv[dg_shared_cs_intros, dg_cs_intros]|
|vdomain dghm_const_ObjMap_vdomain[dg_shared_cs_simps, dg_cs_simps]|
|app dghm_const_ObjMap_app[dg_shared_cs_simps, dg_cs_simps]|
subsubsection‹Arrow map›
mk_VLambda dghm_const_components(2)[folded VLambda_vconst_on]
|vsv dghm_const_ArrMap_vsv[dg_shared_cs_intros, dg_cs_intros]|
|vdomain dghm_const_ArrMap_vdomain[dg_shared_cs_simps, dg_cs_simps]|
|app dghm_const_ArrMap_app[dg_shared_cs_simps, dg_cs_simps]|
subsubsection‹Opposite constant digraph homomorphism›
lemma op_dghm_dghm_const[dg_op_simps]:
"op_dghm (dghm_const ℭ 𝔇 a f) = dghm_const (op_dg ℭ) (op_dg 𝔇) a f"
unfolding dghm_const_def op_dg_def op_dghm_def dghm_field_simps dg_field_simps
by (auto simp: nat_omega_simps)
subsubsection‹A constant digraph homomorphism is a digraph homomorphism›
lemma dghm_const_is_dghm:
assumes "digraph α ℭ" and "digraph α 𝔇" and "f : a ↦⇘𝔇⇙ a"
shows "dghm_const ℭ 𝔇 a f : ℭ ↦↦⇩D⇩G⇘α⇙ 𝔇"
proof-
interpret 𝔇: digraph α 𝔇 by (rule assms(2))
show ?thesis
proof(intro is_dghmI)
show "vfsequence (dghm_const ℭ 𝔇 a f)"
unfolding dghm_const_def by simp
show "vcard (dghm_const ℭ 𝔇 a f) = 4⇩ℕ"
unfolding dghm_const_def by (simp add: nat_omega_simps)
qed
(
use assms in
‹
cs_concl
cs_simp: dghm_const_components(1) dg_cs_simps
cs_intro: V_cs_intros dg_cs_intros
›
)+
qed
lemma dghm_const_is_dghm'[dg_cs_intros]:
assumes "digraph α ℭ"
and "digraph α 𝔇"
and "f : a ↦⇘𝔇⇙ a"
and "𝔄 = ℭ"
and "𝔅 = 𝔇"
shows "dghm_const ℭ 𝔇 a f : 𝔄 ↦↦⇩D⇩G⇘α⇙ 𝔅"
using assms(1-3) unfolding assms(4,5) by (rule dghm_const_is_dghm)
subsection‹Faithful digraph homomorphism›
subsubsection‹Definition and elementary properties›
text‹See Chapter I-3 in \cite{mac_lane_categories_2010}).›
locale is_ft_dghm = is_dghm α 𝔄 𝔅 𝔉 for α 𝔄 𝔅 𝔉 +
assumes ft_dghm_v11_on_Hom:
"⟦ a ∈⇩∘ 𝔄⦇Obj⦈; b ∈⇩∘ 𝔄⦇Obj⦈ ⟧ ⟹ v11 (𝔉⦇ArrMap⦈ ↾⇧l⇩∘ Hom 𝔄 a b)"
syntax "_is_ft_dghm" :: "V ⇒ V ⇒ V ⇒ V ⇒ bool"
(‹(_ :/ _ ↦↦⇩D⇩G⇩.⇩f⇩a⇩i⇩t⇩h⇩f⇩u⇩lı _)› [51, 51, 51] 51)
translations "𝔉 : 𝔄 ↦↦⇩D⇩G⇩.⇩f⇩a⇩i⇩t⇩h⇩f⇩u⇩l⇘α⇙ 𝔅" ⇌ "CONST is_ft_dghm α 𝔄 𝔅 𝔉"
text‹Rules.›
lemma (in is_ft_dghm) is_ft_dghm_axioms'[dghm_cs_intros]:
assumes "α' = α" and "𝔄' = 𝔄" and "𝔅' = 𝔅"
shows "𝔉 : 𝔄' ↦↦⇩D⇩G⇩.⇩f⇩a⇩i⇩t⇩h⇩f⇩u⇩l⇘α'⇙ 𝔅'"
unfolding assms by (rule is_ft_dghm_axioms)
mk_ide rf is_ft_dghm_def[unfolded is_ft_dghm_axioms_def]
|intro is_ft_dghmI|
|dest is_ft_dghmD[dest]|
|elim is_ft_dghmE[elim]|
lemmas [dghm_cs_intros] = is_ft_dghmD(1)
subsubsection‹Opposite faithful digraph homomorphism›
lemma (in is_ft_dghm) ft_dghm_op_dghm_is_ft_dghm:
"op_dghm 𝔉 : op_dg 𝔄 ↦↦⇩D⇩G⇩.⇩f⇩a⇩i⇩t⇩h⇩f⇩u⇩l⇘α⇙ op_dg 𝔅"
by
(
rule is_ft_dghmI,
unfold dg_op_simps,
cs_concl cs_simp: cs_intro: dg_cs_intros dg_op_intros
)
(auto simp: ft_dghm_v11_on_Hom)
lemma (in is_ft_dghm) ft_dghm_op_dghm_is_ft_dghm'[dg_op_intros]:
assumes "𝔄' = op_dg 𝔄" and "𝔅' = op_dg 𝔅"
shows "op_dghm 𝔉 : 𝔄' ↦↦⇩D⇩G⇩.⇩f⇩a⇩i⇩t⇩h⇩f⇩u⇩l⇘α⇙ 𝔅'"
unfolding assms by (rule ft_dghm_op_dghm_is_ft_dghm)
lemmas ft_dghm_op_dghm_is_ft_dghm[dg_op_intros] =
is_ft_dghm.ft_dghm_op_dghm_is_ft_dghm'
subsubsection‹
The composition of faithful digraph homomorphisms is a faithful
digraph homomorphism.
›
lemma dghm_comp_is_ft_dghm[dghm_cs_intros]:
assumes "𝔊 : 𝔅 ↦↦⇩D⇩G⇩.⇩f⇩a⇩i⇩t⇩h⇩f⇩u⇩l⇘α⇙ ℭ" and "𝔉 : 𝔄 ↦↦⇩D⇩G⇩.⇩f⇩a⇩i⇩t⇩h⇩f⇩u⇩l⇘α⇙ 𝔅"
shows "𝔊 ∘⇩D⇩G⇩H⇩M 𝔉 : 𝔄 ↦↦⇩D⇩G⇩.⇩f⇩a⇩i⇩t⇩h⇩f⇩u⇩l⇘α⇙ ℭ"
proof-
interpret L: is_ft_dghm α 𝔅 ℭ 𝔊 using assms(1) by auto
interpret R: is_ft_dghm α 𝔄 𝔅 𝔉 using assms(2) by auto
have inj:
"⟦ a ∈⇩∘ 𝔄⦇Obj⦈ ; b ∈⇩∘ 𝔄⦇Obj⦈ ⟧ ⟹ v11 ((𝔊 ∘⇩D⇩G⇩H⇩M 𝔉)⦇ArrMap⦈ ↾⇧l⇩∘ Hom 𝔄 a b)"
for a b
proof-
assume prems: "a ∈⇩∘ 𝔄⦇Obj⦈" "b ∈⇩∘ 𝔄⦇Obj⦈"
then have 𝔊_hom_𝔅:
"v11 (𝔊⦇ArrMap⦈ ↾⇧l⇩∘ Hom 𝔅 (𝔉⦇ObjMap⦈⦇a⦈) (𝔉⦇ObjMap⦈⦇b⦈))"
by (intro L.ft_dghm_v11_on_Hom)
(cs_concl cs_intro: dg_cs_intros)+
have "v11 (𝔊⦇ArrMap⦈ ↾⇧l⇩∘ (𝔉⦇ArrMap⦈ `⇩∘ Hom 𝔄 a b))"
proof(intro v11_vlrestriction_vsubset[OF 𝔊_hom_𝔅] vsubsetI)
fix g assume "g ∈⇩∘ 𝔉⦇ArrMap⦈ `⇩∘ Hom 𝔄 a b"
then obtain f where f: "f : a ↦⇘𝔄⇙ b" and g_def: "g = 𝔉⦇ArrMap⦈⦇f⦈"
by auto
from f show "g ∈⇩∘ Hom 𝔅 (𝔉⦇ObjMap⦈⦇a⦈) (𝔉⦇ObjMap⦈⦇b⦈)"
by (cs_concl cs_simp: g_def cs_intro: dg_cs_intros)
qed
then show "v11 ((𝔊 ∘⇩D⇩G⇩H⇩M 𝔉)⦇ArrMap⦈ ↾⇧l⇩∘ Hom 𝔄 a b)"
unfolding dghm_comp_components
by (intro v11_vlrestriction_vcomp) (auto simp: R.ft_dghm_v11_on_Hom prems)
qed
then show "𝔊 ∘⇩D⇩G⇩H⇩M 𝔉 : 𝔄 ↦↦⇩D⇩G⇩.⇩f⇩a⇩i⇩t⇩h⇩f⇩u⇩l⇘α⇙ ℭ"
by (intro is_ft_dghmI, cs_concl cs_intro: dg_cs_intros) auto
qed
subsection‹Full digraph homomorphism›
subsubsection‹Definition and elementary properties›
text‹See Chapter I-3 in \cite{mac_lane_categories_2010}.›
locale is_fl_dghm = is_dghm α 𝔄 𝔅 𝔉 for α 𝔄 𝔅 𝔉 +
assumes fl_dghm_surj_on_Hom:
"⟦ a ∈⇩∘ 𝔄⦇Obj⦈; b ∈⇩∘ 𝔄⦇Obj⦈ ⟧ ⟹
𝔉⦇ArrMap⦈ `⇩∘ (Hom 𝔄 a b) = Hom 𝔅 (𝔉⦇ObjMap⦈⦇a⦈) (𝔉⦇ObjMap⦈⦇b⦈)"
syntax "_is_fl_dghm" :: "V ⇒ V ⇒ V ⇒ V ⇒ bool"
(‹(_ :/ _ ↦↦⇩D⇩G⇩.⇩f⇩u⇩l⇩lı _)› [51, 51, 51] 51)
translations "𝔉 : 𝔄 ↦↦⇩D⇩G⇩.⇩f⇩u⇩l⇩l⇘α⇙ 𝔅" ⇌ "CONST is_fl_dghm α 𝔄 𝔅 𝔉"
text‹Rules.›
lemma (in is_fl_dghm) is_fl_dghm_axioms'[dghm_cs_intros]:
assumes "α' = α" and "𝔄' = 𝔄" and "𝔅' = 𝔅"
shows "𝔉 : 𝔄' ↦↦⇩D⇩G⇩.⇩f⇩u⇩l⇩l⇘α'⇙ 𝔅'"
unfolding assms by (rule is_fl_dghm_axioms)
mk_ide rf is_fl_dghm_def[unfolded is_fl_dghm_axioms_def]
|intro is_fl_dghmI|
|dest is_fl_dghmD[dest]|
|elim is_fl_dghmE[elim]|
lemmas [dghm_cs_intros] = is_fl_dghmD(1)
subsubsection‹Opposite full digraph homomorphism›
lemma (in is_fl_dghm) fl_dghm_op_dghm_is_fl_dghm:
"op_dghm 𝔉 : op_dg 𝔄 ↦↦⇩D⇩G⇩.⇩f⇩u⇩l⇩l⇘α⇙ op_dg 𝔅"
by
(
rule is_fl_dghmI,
unfold dg_op_simps,
cs_concl cs_intro: dg_cs_intros dg_op_intros
)
(auto simp: fl_dghm_surj_on_Hom)
lemma (in is_fl_dghm) fl_dghm_op_dghm_is_fl_dghm'[dg_op_intros]:
assumes "𝔄' = op_dg 𝔄" and "𝔅' = op_dg 𝔅"
shows "op_dghm 𝔉 : op_dg 𝔄 ↦↦⇩D⇩G⇩.⇩f⇩u⇩l⇩l⇘α⇙ op_dg 𝔅"
unfolding assms by (rule fl_dghm_op_dghm_is_fl_dghm)
lemmas fl_dghm_op_dghm_is_fl_dghm[dg_op_intros] =
is_fl_dghm.fl_dghm_op_dghm_is_fl_dghm'
subsubsection‹
The composition of full digraph homomorphisms is a full digraph homomorphism
›
lemma dghm_comp_is_fl_dghm[dghm_cs_intros]:
assumes "𝔊 : 𝔅 ↦↦⇩D⇩G⇩.⇩f⇩u⇩l⇩l⇘α⇙ ℭ" and "𝔉 : 𝔄 ↦↦⇩D⇩G⇩.⇩f⇩u⇩l⇩l⇘α⇙ 𝔅"
shows "𝔊 ∘⇩D⇩G⇩H⇩M 𝔉 : 𝔄 ↦↦⇩D⇩G⇩.⇩f⇩u⇩l⇩l⇘α⇙ ℭ"
proof-
interpret L: is_fl_dghm α 𝔅 ℭ 𝔊 by (rule assms(1))
interpret R: is_fl_dghm α 𝔄 𝔅 𝔉 by (rule assms(2))
have surj:
"⟦ a ∈⇩∘ 𝔄⦇Obj⦈; b ∈⇩∘ 𝔄⦇Obj⦈ ⟧ ⟹
(𝔊 ∘⇩D⇩G⇩H⇩M 𝔉)⦇ArrMap⦈ `⇩∘ (Hom 𝔄 a b) =
Hom ℭ ((𝔊 ∘⇩D⇩G⇩H⇩M 𝔉)⦇ObjMap⦈⦇a⦈) ((𝔊 ∘⇩D⇩G⇩H⇩M 𝔉)⦇ObjMap⦈⦇b⦈)"
for a b
proof-
assume prems: "a ∈⇩∘ 𝔄⦇Obj⦈" "b ∈⇩∘ 𝔄⦇Obj⦈"
have surj_𝔉: "𝔉⦇ArrMap⦈ `⇩∘ Hom 𝔄 a b = Hom 𝔅 (𝔉⦇ObjMap⦈⦇a⦈) (𝔉⦇ObjMap⦈⦇b⦈)"
by (rule R.fl_dghm_surj_on_Hom[OF prems])
from prems L.is_dghm_axioms R.is_dghm_axioms have comp_Obj:
"(𝔊 ∘⇩D⇩G⇩H⇩M 𝔉)⦇ObjMap⦈⦇a⦈ = 𝔊⦇ObjMap⦈⦇𝔉⦇ObjMap⦈⦇a⦈⦈"
"(𝔊 ∘⇩D⇩G⇩H⇩M 𝔉)⦇ObjMap⦈⦇b⦈ = 𝔊⦇ObjMap⦈⦇𝔉⦇ObjMap⦈⦇b⦈⦈"
by (auto simp: dg_cs_simps)
have "(𝔊 ∘⇩D⇩G⇩H⇩M 𝔉)⦇ArrMap⦈ `⇩∘ Hom 𝔄 a b = 𝔊⦇ArrMap⦈ `⇩∘ 𝔉⦇ArrMap⦈ `⇩∘ Hom 𝔄 a b"
unfolding dghm_comp_components by (simp add: vcomp_vimage)
also from prems have
"… = Hom ℭ ((𝔊 ∘⇩D⇩G⇩H⇩M 𝔉)⦇ObjMap⦈⦇a⦈) ((𝔊 ∘⇩D⇩G⇩H⇩M 𝔉)⦇ObjMap⦈⦇b⦈)"
unfolding surj_𝔉 comp_Obj
by
(
simp add:
prems(2) L.fl_dghm_surj_on_Hom R.dghm_ObjMap_app_in_HomCod_Obj
)
finally show "(𝔊 ∘⇩D⇩G⇩H⇩M 𝔉)⦇ArrMap⦈ `⇩∘ (Hom 𝔄 a b) =
Hom ℭ ((𝔊 ∘⇩D⇩G⇩H⇩M 𝔉)⦇ObjMap⦈⦇a⦈) ((𝔊 ∘⇩D⇩G⇩H⇩M 𝔉)⦇ObjMap⦈⦇b⦈)"
by simp
qed
show ?thesis
by (rule is_fl_dghmI, cs_concl cs_intro: dg_cs_intros)
(auto simp: surj)
qed
subsection‹Fully faithful digraph homomorphism›
subsubsection‹Definition and elementary properties›
text‹See Chapter I-3 in \cite{mac_lane_categories_2010}.›
locale is_ff_dghm = is_ft_dghm α 𝔄 𝔅 𝔉 + is_fl_dghm α 𝔄 𝔅 𝔉 for α 𝔄 𝔅 𝔉
syntax "_is_ff_dghm" :: "V ⇒ V ⇒ V ⇒ V ⇒ bool"
(‹(_ :/ _ ↦↦⇩D⇩G⇩.⇩f⇩fı _)› [51, 51, 51] 51)
translations "𝔉 : 𝔄 ↦↦⇩D⇩G⇩.⇩f⇩f⇘α⇙ 𝔅" ⇌ "CONST is_ff_dghm α 𝔄 𝔅 𝔉"
text‹Rules.›
lemma (in is_ff_dghm) is_ff_dghm_axioms'[dghm_cs_intros]:
assumes "α' = α" and "𝔄' = 𝔄" and "𝔅' = 𝔅"
shows "𝔉 : 𝔄' ↦↦⇩D⇩G⇩.⇩f⇩f⇘α'⇙ 𝔅'"
unfolding assms by (rule is_ff_dghm_axioms)
mk_ide rf is_ff_dghm_def
|intro is_ff_dghmI|
|dest is_ff_dghmD[dest]|
|elim is_ff_dghmE[elim]|
lemmas [dghm_cs_intros] = is_ff_dghmD
subsubsection‹Opposite fully faithful digraph homomorphism.›
lemma (in is_ff_dghm) ff_dghm_op_dghm_is_ff_dghm:
"op_dghm 𝔉 : op_dg 𝔄 ↦↦⇩D⇩G⇩.⇩f⇩f⇘α⇙ op_dg 𝔅"
by (rule is_ff_dghmI) (cs_concl cs_intro: dg_op_intros)+
lemma (in is_ff_dghm) ff_dghm_op_dghm_is_ff_dghm'[dg_op_intros]:
assumes "𝔄' = op_dg 𝔄" and "𝔅' = op_dg 𝔅"
shows "op_dghm 𝔉 : 𝔄' ↦↦⇩D⇩G⇩.⇩f⇩f⇘α⇙ 𝔅'"
unfolding assms by (rule ff_dghm_op_dghm_is_ff_dghm)
lemmas ff_dghm_op_dghm_is_ff_dghm[dg_op_intros] =
is_ff_dghm.ff_dghm_op_dghm_is_ff_dghm
subsubsection‹
The composition of fully faithful digraph homomorphisms is
a fully faithful digraph homomorphism.
›
lemma dghm_comp_is_ff_dghm[dghm_cs_intros]:
assumes "𝔊 : 𝔅 ↦↦⇩D⇩G⇩.⇩f⇩f⇘α⇙ ℭ" and "𝔉 : 𝔄 ↦↦⇩D⇩G⇩.⇩f⇩f⇘α⇙ 𝔅"
shows "𝔊 ∘⇩D⇩G⇩H⇩M 𝔉 : 𝔄 ↦↦⇩D⇩G⇩.⇩f⇩f⇘α⇙ ℭ"
using assms
by (intro is_ff_dghmI, elim is_ff_dghmE) (cs_concl cs_intro: dghm_cs_intros)
subsection‹Isomorphism of digraphs›
subsubsection‹Definition and elementary properties›
text‹See Chapter I-3 in \cite{mac_lane_categories_2010}.›
locale is_iso_dghm = is_dghm α 𝔄 𝔅 𝔉 for α 𝔄 𝔅 𝔉 +
assumes iso_dghm_ObjMap_v11: "v11 (𝔉⦇ObjMap⦈)"
and iso_dghm_ArrMap_v11: "v11 (𝔉⦇ArrMap⦈)"
and iso_dghm_ObjMap_vrange[dghm_cs_simps]: "ℛ⇩∘ (𝔉⦇ObjMap⦈) = 𝔅⦇Obj⦈"
and iso_dghm_ArrMap_vrange[dghm_cs_simps]: "ℛ⇩∘ (𝔉⦇ArrMap⦈) = 𝔅⦇Arr⦈"
syntax "_is_iso_dghm" :: "V ⇒ V ⇒ V ⇒ V ⇒ bool"
(‹(_ :/ _ ↦↦⇩D⇩G⇩.⇩i⇩s⇩oı _)› [51, 51, 51] 51)
translations "𝔉 : 𝔄 ↦↦⇩D⇩G⇩.⇩i⇩s⇩o⇘α⇙ 𝔅" ⇌ "CONST is_iso_dghm α 𝔄 𝔅 𝔉"
sublocale is_iso_dghm ⊆ ObjMap: v11 ‹𝔉⦇ObjMap⦈›
rewrites "𝒟⇩∘ (𝔉⦇ObjMap⦈) = 𝔄⦇Obj⦈" and "ℛ⇩∘ (𝔉⦇ObjMap⦈) = 𝔅⦇Obj⦈"
by (cs_concl cs_simp: dghm_cs_simps dg_cs_simps cs_intro: iso_dghm_ObjMap_v11)+
sublocale is_iso_dghm ⊆ ArrMap: v11 ‹𝔉⦇ArrMap⦈›
rewrites "𝒟⇩∘ (𝔉⦇ArrMap⦈) = 𝔄⦇Arr⦈" and "ℛ⇩∘ (𝔉⦇ArrMap⦈) = 𝔅⦇Arr⦈"
by (cs_concl cs_simp: dghm_cs_simps dg_cs_simps cs_intro: iso_dghm_ArrMap_v11)+
lemmas [dghm_cs_simps] =
is_iso_dghm.iso_dghm_ObjMap_vrange
is_iso_dghm.iso_dghm_ArrMap_vrange
text‹Rules.›
lemma (in is_iso_dghm) is_iso_dghm_axioms'[dghm_cs_intros]:
assumes "α' = α" and "𝔄' = 𝔄" and "𝔅' = 𝔅"
shows "𝔉 : 𝔄' ↦↦⇩D⇩G⇩.⇩i⇩s⇩o⇘α'⇙ 𝔅'"
unfolding assms by (rule is_iso_dghm_axioms)
mk_ide rf is_iso_dghm_def[unfolded is_iso_dghm_axioms_def]
|intro is_iso_dghmI|
|dest is_iso_dghmD[dest]|
|elim is_iso_dghmE[elim]|
text‹Elementary properties.›
lemma (in is_iso_dghm) iso_dghm_Obj_HomDom_if_Obj_HomCod[elim]:
assumes "b ∈⇩∘ 𝔅⦇Obj⦈"
obtains a where "a ∈⇩∘ 𝔄⦇Obj⦈" and "b = 𝔉⦇ObjMap⦈⦇a⦈"
using assms ObjMap.vrange_atD iso_dghm_ObjMap_vrange by blast
lemma (in is_iso_dghm) iso_dghm_Arr_HomDom_if_Arr_HomCod[elim]:
assumes "g ∈⇩∘ 𝔅⦇Arr⦈"
obtains f where "f ∈⇩∘ 𝔄⦇Arr⦈" and "g = 𝔉⦇ArrMap⦈⦇f⦈"
using assms ArrMap.vrange_atD iso_dghm_ArrMap_vrange by blast
lemma (in is_iso_dghm) iso_dghm_ObjMap_eqE[elim]:
assumes "𝔉⦇ObjMap⦈⦇a⦈ = 𝔉⦇ObjMap⦈⦇b⦈"
and "a ∈⇩∘ 𝔄⦇Obj⦈"
and "b ∈⇩∘ 𝔄⦇Obj⦈"
and "a = b ⟹ P"
shows P
using assms ObjMap.v11_eq_iff by auto
lemma (in is_iso_dghm) iso_dghm_ArrMap_eqE[elim]:
assumes "𝔉⦇ArrMap⦈⦇f⦈ = 𝔉⦇ArrMap⦈⦇g⦈"
and "f ∈⇩∘ 𝔄⦇Arr⦈"
and "g ∈⇩∘ 𝔄⦇Arr⦈"
and "f = g ⟹ P"
shows P
using assms ArrMap.v11_eq_iff by auto
sublocale is_iso_dghm ⊆ is_ft_dghm
by (intro is_ft_dghmI, cs_concl cs_intro: dg_cs_intros) auto
sublocale is_iso_dghm ⊆ is_fl_dghm
proof
fix a b assume [intro]: "a ∈⇩∘ 𝔄⦇Obj⦈" "b ∈⇩∘ 𝔄⦇Obj⦈"
show "𝔉⦇ArrMap⦈ `⇩∘ Hom 𝔄 a b = Hom 𝔅 (𝔉⦇ObjMap⦈⦇a⦈) (𝔉⦇ObjMap⦈⦇b⦈)"
proof(intro vsubset_antisym vsubsetI)
fix g assume prems: "g ∈⇩∘ Hom 𝔅 (𝔉⦇ObjMap⦈⦇a⦈) (𝔉⦇ObjMap⦈⦇b⦈)"
then have g: "g : 𝔉⦇ObjMap⦈⦇a⦈ ↦⇘𝔅⇙ 𝔉⦇ObjMap⦈⦇b⦈" by auto
then have dom_g: "𝔅⦇Dom⦈⦇g⦈ = 𝔉⦇ObjMap⦈⦇a⦈"
and cod_g: "𝔅⦇Cod⦈⦇g⦈ = 𝔉⦇ObjMap⦈⦇b⦈"
by blast+
from prems obtain f
where [intro, simp]: "f ∈⇩∘ 𝔄⦇Arr⦈" and g_def: "g = 𝔉⦇ArrMap⦈⦇f⦈"
by auto
then obtain a' b' where f: "f : a' ↦⇘𝔄⇙ b'" by blast
then have "g : 𝔉⦇ObjMap⦈⦇a'⦈ ↦⇘𝔅⇙ 𝔉⦇ObjMap⦈⦇b'⦈"
by (cs_concl cs_simp: g_def dg_cs_simps cs_intro: dg_cs_intros)
with g have "𝔉⦇ObjMap⦈⦇a⦈ = 𝔉⦇ObjMap⦈⦇a'⦈" and "𝔉⦇ObjMap⦈⦇b⦈ = 𝔉⦇ObjMap⦈⦇b'⦈"
by (metis HomCod.dg_is_arrE cod_g)+
with f have "a = 𝔄⦇Dom⦈⦇f⦈" "b = 𝔄⦇Cod⦈⦇f⦈" by auto
with f show "g ∈⇩∘ 𝔉⦇ArrMap⦈ `⇩∘ Hom 𝔄 a b"
by (auto simp: g_def HomDom.dg_is_arrD(4,5) ArrMap.vsv_vimageI1)
qed (metis ArrMap.vsv_vimageE dghm_ArrMap_is_arr' in_Hom_iff)
qed
sublocale is_iso_dghm ⊆ is_ff_dghm by unfold_locales
lemmas (in is_iso_dghm) iso_dghm_is_ff_dghm = is_ff_dghm_axioms
lemmas [dghm_cs_intros] = is_iso_dghm.iso_dghm_is_ff_dghm
subsubsection‹Opposite digraph isomorphisms›
lemma (in is_iso_dghm) is_iso_dghm_op:
"op_dghm 𝔉 : op_dg 𝔄 ↦↦⇩D⇩G⇩.⇩i⇩s⇩o⇘α⇙ op_dg 𝔅"
by (intro is_iso_dghmI, unfold dg_op_simps)
(
cs_concl
cs_simp: dghm_cs_simps cs_intro: V_cs_intros dg_cs_intros dg_op_intros
)+
lemma (in is_iso_dghm) is_iso_dghm_op':
assumes "𝔄' = op_dg 𝔄" and "𝔅' = op_dg 𝔅"
shows "op_dghm 𝔉 : 𝔄' ↦↦⇩D⇩G⇩.⇩i⇩s⇩o⇘α⇙ 𝔅'"
unfolding assms by (rule is_iso_dghm_op)
lemmas is_iso_dghm_op[dg_op_intros] = is_iso_dghm.is_iso_dghm_op'
subsubsection‹
The composition of isomorphisms of digraphs is an isomorphism of digraphs
›
lemma dghm_comp_is_iso_dghm[dghm_cs_intros]:
assumes "𝔊 : 𝔅 ↦↦⇩D⇩G⇩.⇩i⇩s⇩o⇘α⇙ ℭ" and "𝔉 : 𝔄 ↦↦⇩D⇩G⇩.⇩i⇩s⇩o⇘α⇙ 𝔅"
shows "𝔊 ∘⇩D⇩G⇩H⇩M 𝔉 : 𝔄 ↦↦⇩D⇩G⇩.⇩i⇩s⇩o⇘α⇙ ℭ"
proof-
interpret 𝔉: is_iso_dghm α 𝔄 𝔅 𝔉 using assms by auto
interpret 𝔊: is_iso_dghm α 𝔅 ℭ 𝔊 using assms by auto
show ?thesis
by (intro is_iso_dghmI, unfold dghm_comp_components)
(
cs_concl
cs_simp: V_cs_simps dg_cs_simps dghm_cs_simps
cs_intro: dg_cs_intros V_cs_intros
)+
qed
subsubsection‹An identity digraph homomorphism is an isomorphism of digraphs.›
lemma (in digraph) dg_dghm_id_is_iso_dghm: "dghm_id ℭ : ℭ ↦↦⇩D⇩G⇩.⇩i⇩s⇩o⇘α⇙ ℭ"
by (rule is_iso_dghmI) (simp_all add: dg_dghm_id_is_dghm dghm_id_components)
lemma (in digraph) dg_dghm_id_is_iso_dghm'[dghm_cs_intros]:
assumes "𝔄' = ℭ" and "𝔅' = ℭ"
shows "dghm_id ℭ : 𝔄' ↦↦⇩D⇩G⇩.⇩i⇩s⇩o⇘α⇙ 𝔅'"
unfolding assms by (rule dg_dghm_id_is_iso_dghm)
lemmas [dghm_cs_intros] = digraph.dg_dghm_id_is_iso_dghm'
subsection‹Inverse digraph homomorphism›
subsubsection‹Definition and elementary properties›
definition inv_dghm :: "V ⇒ V"
where "inv_dghm 𝔉 = [(𝔉⦇ObjMap⦈)¯⇩∘, (𝔉⦇ArrMap⦈)¯⇩∘, 𝔉⦇HomCod⦈, 𝔉⦇HomDom⦈]⇩∘"
text‹Components.›
lemma inv_dghm_components:
shows "inv_dghm 𝔉⦇ObjMap⦈ = (𝔉⦇ObjMap⦈)¯⇩∘"
and "inv_dghm 𝔉⦇ArrMap⦈ = (𝔉⦇ArrMap⦈)¯⇩∘"
and [dghm_cs_simps]: "inv_dghm 𝔉⦇HomDom⦈ = 𝔉⦇HomCod⦈"
and [dghm_cs_simps]: "inv_dghm 𝔉⦇HomCod⦈ = 𝔉⦇HomDom⦈"
unfolding inv_dghm_def dghm_field_simps by (simp_all add: nat_omega_simps)
subsubsection‹Object map›
lemma (in is_iso_dghm) inv_dghm_ObjMap_v11[dghm_cs_intros]:
"v11 (inv_dghm 𝔉⦇ObjMap⦈)"
unfolding inv_dghm_components by (cs_concl cs_intro: V_cs_intros)
lemmas [dghm_cs_intros] = is_iso_dghm.inv_dghm_ObjMap_v11
lemma (in is_iso_dghm) inv_dghm_ObjMap_vdomain[dghm_cs_simps]:
"𝒟⇩∘ (inv_dghm 𝔉⦇ObjMap⦈) = 𝔅⦇Obj⦈"
unfolding inv_dghm_components by (cs_concl cs_simp: dghm_cs_simps V_cs_simps)
lemmas [dghm_cs_simps] = is_iso_dghm.inv_dghm_ObjMap_vdomain
lemma (in is_iso_dghm) inv_dghm_ObjMap_app[dghm_cs_simps]:
assumes "a' = 𝔉⦇ObjMap⦈⦇a⦈" and "a ∈⇩∘ 𝔄⦇Obj⦈"
shows "inv_dghm 𝔉⦇ObjMap⦈⦇a'⦈ = a"
unfolding inv_dghm_components
by (metis assms ObjMap.vconverse_atI ObjMap.vsv_vconverse vsv.vsv_appI)
lemmas [dghm_cs_simps] = is_iso_dghm.inv_dghm_ObjMap_app
lemma (in is_iso_dghm) inv_dghm_ObjMap_vrange[dghm_cs_simps]:
"ℛ⇩∘ (inv_dghm 𝔉⦇ObjMap⦈) = 𝔄⦇Obj⦈"
unfolding inv_dghm_components by (cs_concl cs_simp: dg_cs_simps V_cs_simps)
lemmas [dghm_cs_simps] = is_iso_dghm.inv_dghm_ObjMap_vrange
subsubsection‹Arrow map›
lemma (in is_iso_dghm) inv_dghm_ArrMap_v11[dghm_cs_intros]:
"v11 (inv_dghm 𝔉⦇ArrMap⦈)"
unfolding inv_dghm_components by (cs_concl cs_intro: V_cs_intros)
lemmas [dghm_cs_intros] = is_iso_dghm.inv_dghm_ArrMap_v11
lemma (in is_iso_dghm) inv_dghm_ArrMap_vdomain[dghm_cs_simps]:
"𝒟⇩∘ (inv_dghm 𝔉⦇ArrMap⦈) = 𝔅⦇Arr⦈"
unfolding inv_dghm_components by (cs_concl cs_simp: dghm_cs_simps V_cs_simps)
lemmas [dghm_cs_simps] = is_iso_dghm.inv_dghm_ArrMap_vdomain
lemma (in is_iso_dghm) inv_dghm_ArrMap_app[dghm_cs_simps]:
assumes "a' = 𝔉⦇ArrMap⦈⦇a⦈" and "a ∈⇩∘ 𝔄⦇Arr⦈"
shows "inv_dghm 𝔉⦇ArrMap⦈⦇a'⦈ = a"
unfolding inv_dghm_components
by (metis assms ArrMap.vconverse_atI ArrMap.vsv_vconverse vsv.vsv_appI)
lemmas [dghm_cs_simps] = is_iso_dghm.inv_dghm_ArrMap_app
lemma (in is_iso_dghm) inv_dghm_ArrMap_vrange[dghm_cs_simps]:
"ℛ⇩∘ (inv_dghm 𝔉⦇ArrMap⦈) = 𝔄⦇Arr⦈"
unfolding inv_dghm_components by (cs_concl cs_simp: dg_cs_simps V_cs_simps)
lemmas [dghm_cs_simps] = is_iso_dghm.inv_dghm_ArrMap_vrange
subsubsection‹Further properties›
lemma (in is_iso_dghm) iso_dghm_ObjMap_inv_dghm_ObjMap_app[dghm_cs_simps]:
assumes "a ∈⇩∘ 𝔅⦇Obj⦈"
shows "𝔉⦇ObjMap⦈⦇inv_dghm 𝔉⦇ObjMap⦈⦇a⦈⦈ = a"
using assms by (cs_concl cs_simp: inv_dghm_components V_cs_simps)
lemmas [dghm_cs_simps] = is_iso_dghm.iso_dghm_ObjMap_inv_dghm_ObjMap_app
lemma (in is_iso_dghm) iso_dghm_ArrMap_inv_dghm_ArrMap_app[dghm_cs_simps]:
assumes "f : a ↦⇘𝔅⇙ b"
shows "𝔉⦇ArrMap⦈⦇inv_dghm 𝔉⦇ArrMap⦈⦇f⦈⦈ = f"
using assms
by (cs_concl cs_simp: inv_dghm_components V_cs_simps cs_intro: dg_cs_intros)
lemmas [dghm_cs_simps] = is_iso_dghm.iso_dghm_ArrMap_inv_dghm_ArrMap_app
lemma (in is_iso_dghm) iso_dghm_HomDom_is_arr_conv:
assumes "f ∈⇩∘ 𝔄⦇Arr⦈"
and "a ∈⇩∘ 𝔄⦇Obj⦈"
and "b ∈⇩∘ 𝔄⦇Obj⦈"
and "𝔉⦇ArrMap⦈⦇f⦈ : 𝔉⦇ObjMap⦈⦇a⦈ ↦⇘𝔅⇙ 𝔉⦇ObjMap⦈⦇b⦈"
shows "f : a ↦⇘𝔄⇙ b"
by
(
metis
assms
HomDom.dg_is_arrE
is_arr_def
dghm_ArrMap_is_arr
iso_dghm_ObjMap_eqE
)
lemma (in is_iso_dghm) iso_dghm_HomCod_is_arr_conv:
assumes "f ∈⇩∘ 𝔅⦇Arr⦈"
and "a ∈⇩∘ 𝔅⦇Obj⦈"
and "b ∈⇩∘ 𝔅⦇Obj⦈"
and "inv_dghm 𝔉⦇ArrMap⦈⦇f⦈ : inv_dghm 𝔉⦇ObjMap⦈⦇a⦈ ↦⇘𝔄⇙ inv_dghm 𝔉⦇ObjMap⦈⦇b⦈"
shows "f : a ↦⇘𝔅⇙ b"
by
(
metis
assms
dghm_ArrMap_is_arr'
is_arrI
iso_dghm_ArrMap_inv_dghm_ArrMap_app
iso_dghm_ObjMap_inv_dghm_ObjMap_app
)
subsection‹An isomorphism of digraphs is an isomorphism in the category ‹GRPH››
text‹See Chapter I-3 in \cite{mac_lane_categories_2010}).›
lemma is_arr_isomorphism_is_iso_dghm:
assumes "𝔉 : 𝔄 ↦↦⇩D⇩G⇘α⇙ 𝔅"
and "𝔊 : 𝔅 ↦↦⇩D⇩G⇘α⇙ 𝔄"
and "𝔊 ∘⇩D⇩G⇩H⇩M 𝔉 = dghm_id 𝔄"
and "𝔉 ∘⇩D⇩G⇩H⇩M 𝔊 = dghm_id 𝔅"
shows "𝔉 : 𝔄 ↦↦⇩D⇩G⇩.⇩i⇩s⇩o⇘α⇙ 𝔅"
proof(intro is_iso_dghmI)
interpret L: is_dghm α 𝔅 𝔄 𝔊 by (rule assms(2))
interpret R: is_dghm α 𝔄 𝔅 𝔉 by (rule assms(1))
show "𝔉 : 𝔄 ↦↦⇩D⇩G⇘α⇙ 𝔅" by (cs_concl cs_intro: dg_cs_intros)
show "v11 (𝔉⦇ObjMap⦈)"
proof(rule R.ObjMap.vsv_valeq_v11I)
fix a b assume prems[simp]:
"a ∈⇩∘ 𝔄⦇Obj⦈" "b ∈⇩∘ 𝔄⦇Obj⦈" "𝔉⦇ObjMap⦈⦇a⦈ = 𝔉⦇ObjMap⦈⦇b⦈"
from assms(1,2) have "(𝔊 ∘⇩D⇩G⇩H⇩M 𝔉)⦇ObjMap⦈⦇a⦈ = (𝔊 ∘⇩D⇩G⇩H⇩M 𝔉)⦇ObjMap⦈⦇b⦈"
by (simp add: dg_cs_simps)
then show "a = b" by (simp add: assms(3) dghm_id_components)
qed
show "v11 (𝔉⦇ArrMap⦈)"
proof(rule R.ArrMap.vsv_valeq_v11I)
fix a b
assume prems[simp]:
"a ∈⇩∘ 𝔄⦇Arr⦈" "b ∈⇩∘ 𝔄⦇Arr⦈" "𝔉⦇ArrMap⦈⦇a⦈ = 𝔉⦇ArrMap⦈⦇b⦈"
then have "𝔉⦇ArrMap⦈⦇a⦈ ∈⇩∘ 𝔅⦇Arr⦈"
by (cs_concl cs_intro: dg_cs_intros)
with R.dghm_ArrMap_vsv L.dghm_ArrMap_vsv R.dghm_ArrMap_vrange have
"(𝔊 ∘⇩D⇩G⇩H⇩M 𝔉)⦇ArrMap⦈⦇a⦈ = (𝔊 ∘⇩D⇩G⇩H⇩M 𝔉)⦇ArrMap⦈⦇b⦈"
unfolding dghm_comp_components by (simp add: dg_cs_simps)
then show "a = b" by (simp add: assms(3) dghm_id_components)
qed
show "ℛ⇩∘ (𝔉⦇ObjMap⦈) = 𝔅⦇Obj⦈"
proof(intro vsubset_antisym vsubsetI)
from R.dghm_ObjMap_vrange show "a ∈⇩∘ ℛ⇩∘ (𝔉⦇ObjMap⦈) ⟹ a ∈⇩∘ 𝔅⦇Obj⦈" for a
by auto
next
fix a assume prems: "a ∈⇩∘ 𝔅⦇Obj⦈"
then have a_def[symmetric]: "(𝔉 ∘⇩D⇩G⇩H⇩M 𝔊)⦇ObjMap⦈⦇a⦈ = a"
unfolding assms(4) dghm_id_components by simp
from prems show "a ∈⇩∘ ℛ⇩∘ (𝔉⦇ObjMap⦈)"
by (subst a_def)
(cs_concl cs_intro: V_cs_intros dg_cs_intros cs_simp: dg_cs_simps)
qed
show "ℛ⇩∘ (𝔉⦇ArrMap⦈) = 𝔅⦇Arr⦈"
proof(intro vsubset_antisym vsubsetI)
from R.dghm_ArrMap_vrange show "a ∈⇩∘ ℛ⇩∘ (𝔉⦇ArrMap⦈) ⟹ a ∈⇩∘ 𝔅⦇Arr⦈" for a
by auto
next
fix a assume prems: "a ∈⇩∘ 𝔅⦇Arr⦈"
then have a_def[symmetric]: "(𝔉 ∘⇩D⇩G⇩H⇩M 𝔊)⦇ArrMap⦈⦇a⦈ = a"
unfolding assms(4) dghm_id_components by simp
with prems show "a ∈⇩∘ ℛ⇩∘ (𝔉⦇ArrMap⦈)"
by (subst a_def)
(cs_concl cs_intro: V_cs_intros dg_cs_intros cs_simp: dg_cs_simps)
qed
qed
lemma is_iso_dghm_is_arr_isomorphism:
assumes "𝔉 : 𝔄 ↦↦⇩D⇩G⇩.⇩i⇩s⇩o⇘α⇙ 𝔅"
shows [dghm_cs_intros]: "inv_dghm 𝔉 : 𝔅 ↦↦⇩D⇩G⇩.⇩i⇩s⇩o⇘α⇙ 𝔄"
and "inv_dghm 𝔉 ∘⇩D⇩G⇩H⇩M 𝔉 = dghm_id 𝔄"
and "𝔉 ∘⇩D⇩G⇩H⇩M inv_dghm 𝔉 = dghm_id 𝔅"
proof-
let ?𝔊 = ‹inv_dghm 𝔉›
interpret is_iso_dghm α 𝔄 𝔅 𝔉 by (rule assms(1))
show 𝔊: "?𝔊 : 𝔅 ↦↦⇩D⇩G⇩.⇩i⇩s⇩o⇘α⇙ 𝔄"
proof(intro is_iso_dghmI is_dghmI, unfold dghm_cs_simps)
show "vfsequence (inv_dghm 𝔉)" unfolding inv_dghm_def by auto
show "vcard (inv_dghm 𝔉) = 4⇩ℕ"
unfolding inv_dghm_def by (simp add: nat_omega_simps)
show "inv_dghm 𝔉⦇ArrMap⦈⦇f⦈ : inv_dghm 𝔉⦇ObjMap⦈⦇a⦈ ↦⇘𝔄⇙ inv_dghm 𝔉⦇ObjMap⦈⦇b⦈"
if "f : a ↦⇘𝔅⇙ b" for a b f
using that
by
(
intro iso_dghm_HomDom_is_arr_conv,
use nothing in ‹unfold inv_dghm_components›
)
(
cs_concl
cs_simp: V_cs_simps dghm_cs_simps dg_cs_simps
cs_intro: dg_cs_intros V_cs_intros
)+
qed
(
cs_concl
cs_simp: dg_cs_simps
cs_intro: dg_cs_intros V_cs_intros dghm_cs_intros
)+
show "inv_dghm 𝔉 ∘⇩D⇩G⇩H⇩M 𝔉 = dghm_id 𝔄"
proof(rule dghm_eqI[of α 𝔄 𝔄 _ 𝔄 𝔄])
show "(inv_dghm 𝔉 ∘⇩D⇩G⇩H⇩M 𝔉)⦇ObjMap⦈ = dghm_id 𝔄⦇ObjMap⦈"
unfolding inv_dghm_components dghm_comp_components dghm_id_components
by (rule ObjMap.v11_vcomp_vconverse)
show "(inv_dghm 𝔉 ∘⇩D⇩G⇩H⇩M 𝔉)⦇ArrMap⦈ = dghm_id 𝔄⦇ArrMap⦈"
unfolding inv_dghm_components dghm_comp_components dghm_id_components
by (rule ArrMap.v11_vcomp_vconverse)
qed (use 𝔊 in ‹cs_concl cs_intro: dghm_cs_intros›)
show "𝔉 ∘⇩D⇩G⇩H⇩M inv_dghm 𝔉 = dghm_id 𝔅"
proof(rule dghm_eqI[of α 𝔅 𝔅 _ 𝔅 𝔅])
show "(𝔉 ∘⇩D⇩G⇩H⇩M inv_dghm 𝔉)⦇ObjMap⦈ = dghm_id 𝔅⦇ObjMap⦈"
unfolding inv_dghm_components dghm_comp_components dghm_id_components
by (rule ObjMap.v11_vcomp_vconverse')
show "(𝔉 ∘⇩D⇩G⇩H⇩M inv_dghm 𝔉)⦇ArrMap⦈ = dghm_id 𝔅⦇ArrMap⦈"
unfolding inv_dghm_components dghm_comp_components dghm_id_components
by (rule ArrMap.v11_vcomp_vconverse')
qed (use 𝔊 in ‹cs_concl cs_intro: dghm_cs_intros›)
qed
subsection‹Isomorphic digraphs›
subsubsection‹Definition and elementary properties›
text‹See Chapter I-3 in \cite{mac_lane_categories_2010}).›
locale iso_digraph =
fixes α 𝔄 𝔅 :: V
assumes iso_digraph_is_iso_dghm: "∃𝔉. 𝔉 : 𝔄 ↦↦⇩D⇩G⇩.⇩i⇩s⇩o⇘α⇙ 𝔅"
notation iso_digraph (infixl "≈⇩D⇩Gı" 50)
sublocale iso_digraph ⊆ HomDom: digraph α 𝔄 + HomCod: digraph α 𝔅
using iso_digraph_is_iso_dghm by auto
text‹Rules.›
lemma iso_digraphI':
assumes "∃𝔉. 𝔉 : 𝔄 ↦↦⇩D⇩G⇩.⇩i⇩s⇩o⇘α⇙ 𝔅"
shows "𝔄 ≈⇩D⇩G⇘α⇙ 𝔅"
using assms iso_digraph.intro by auto
lemma iso_digraphI:
assumes "𝔉 : 𝔄 ↦↦⇩D⇩G⇩.⇩i⇩s⇩o⇘α⇙ 𝔅"
shows "𝔄 ≈⇩D⇩G⇘α⇙ 𝔅"
using assms unfolding iso_digraph_def by auto
lemma iso_digraphD[dest]:
assumes "𝔄 ≈⇩D⇩G⇘α⇙ 𝔅"
shows "∃𝔉. 𝔉 : 𝔄 ↦↦⇩D⇩G⇩.⇩i⇩s⇩o⇘α⇙ 𝔅"
using assms unfolding iso_digraph_def by simp_all
lemma iso_digraphE[elim]:
assumes "𝔄 ≈⇩D⇩G⇘α⇙ 𝔅"
obtains 𝔉 where "𝔉 : 𝔄 ↦↦⇩D⇩G⇩.⇩i⇩s⇩o⇘α⇙ 𝔅"
using assms by auto
subsubsection‹A digraph isomorphism is an equivalence relation›
lemma iso_digraph_refl:
assumes "digraph α 𝔄"
shows "𝔄 ≈⇩D⇩G⇘α⇙ 𝔄"
proof(rule iso_digraphI[of _ _ _ ‹dghm_id 𝔄›])
interpret digraph α 𝔄 by (rule assms)
show "dghm_id 𝔄 : 𝔄 ↦↦⇩D⇩G⇩.⇩i⇩s⇩o⇘α⇙ 𝔄" by (rule dg_dghm_id_is_iso_dghm)
qed
lemma iso_digraph_sym[sym]:
assumes "𝔄 ≈⇩D⇩G⇘α⇙ 𝔅"
shows "𝔅 ≈⇩D⇩G⇘α⇙ 𝔄"
proof-
interpret iso_digraph α 𝔄 𝔅 by (rule assms)
from iso_digraph_is_iso_dghm obtain 𝔉 where "𝔉 : 𝔄 ↦↦⇩D⇩G⇩.⇩i⇩s⇩o⇘α⇙ 𝔅"
by clarsimp
then have "inv_dghm 𝔉 : 𝔅 ↦↦⇩D⇩G⇩.⇩i⇩s⇩o⇘α⇙ 𝔄"
by (simp add: is_iso_dghm_is_arr_isomorphism(1))
then show ?thesis by (cs_concl cs_intro: dghm_cs_intros iso_digraphI)
qed
lemma iso_digraph_trans[trans]:
assumes "𝔄 ≈⇩D⇩G⇘α⇙ 𝔅" and "𝔅 ≈⇩D⇩G⇘α⇙ ℭ"
shows "𝔄 ≈⇩D⇩G⇘α⇙ ℭ"
proof-
interpret L: iso_digraph α 𝔄 𝔅 by (rule assms(1))
interpret R: iso_digraph α 𝔅 ℭ by (rule assms(2))
from L.iso_digraph_is_iso_dghm R.iso_digraph_is_iso_dghm show ?thesis
by (meson dghm_comp_is_iso_dghm iso_digraph.intro)
qed
text‹\newpage›
end
Theory CZH_DG_Small_DGHM
section‹Smallness for digraph homomorphisms›
theory CZH_DG_Small_DGHM
imports
CZH_DG_Small_Digraph
CZH_DG_DGHM
begin
subsection‹Digraph homomorphism with tiny maps›
subsubsection‹Definition and elementary properties›
text‹
The following construction is based on the concept
of a ‹small functor› used in \cite{shulman_set_2008}
in the context of the presentation of the set theory ‹ZFC/S›.
›
locale is_tm_dghm =
is_dghm α 𝔄 𝔅 𝔉 +
HomDom: digraph α 𝔄 +
HomCod: digraph α 𝔅
for α 𝔄 𝔅 𝔉 +
assumes tm_dghm_ObjMap_in_Vset[dg_small_cs_intros]: "𝔉⦇ObjMap⦈ ∈⇩∘ Vset α"
and tm_dghm_ArrMap_in_Vset[dg_small_cs_intros]: "𝔉⦇ArrMap⦈ ∈⇩∘ Vset α"
syntax "_is_tm_dghm" :: "V ⇒ V ⇒ V ⇒ V ⇒ bool"
(‹(_ :/ _ ↦↦⇩D⇩G⇩.⇩t⇩mı _)› [51, 51, 51] 51)
translations "𝔉 : 𝔄 ↦↦⇩D⇩G⇩.⇩t⇩m⇘α⇙ 𝔅" ⇌ "CONST is_tm_dghm α 𝔄 𝔅 𝔉"
abbreviation (input) is_cn_tm_dghm :: "V ⇒ V ⇒ V ⇒ V ⇒ bool"
where "is_cn_tm_dghm α 𝔄 𝔅 𝔉 ≡ 𝔉 : op_dg 𝔄 ↦↦⇩D⇩G⇩.⇩t⇩m⇘α⇙ 𝔅"
syntax "_is_cn_tm_dghm" :: "V ⇒ V ⇒ V ⇒ V ⇒ bool"
(‹(_ :/ _ ⇩D⇩G⇩.⇩t⇩m↦↦ı _)› [51, 51, 51] 51)
translations "𝔉 : 𝔄 ⇩D⇩G⇩.⇩t⇩m↦↦⇘α⇙ 𝔅" ⇀ "CONST is_cn_tm_dghm α 𝔄 𝔅 𝔉"
abbreviation all_tm_dghms :: "V ⇒ V"
where "all_tm_dghms α ≡ set {𝔉. ∃𝔄 𝔅. 𝔉 : 𝔄 ↦↦⇩D⇩G⇩.⇩t⇩m⇘α⇙ 𝔅}"
abbreviation small_tm_dghms :: "V ⇒ V ⇒ V ⇒ V"
where "small_tm_dghms α 𝔄 𝔅 ≡ set {𝔉. 𝔉 : 𝔄 ↦↦⇩D⇩G⇩.⇩t⇩m⇘α⇙ 𝔅}"
lemmas [dg_small_cs_intros] =
is_tm_dghm.tm_dghm_ObjMap_in_Vset
is_tm_dghm.tm_dghm_ArrMap_in_Vset
text‹Rules.›
lemma (in is_tm_dghm) is_tm_dghm_axioms'[dg_small_cs_intros]:
assumes "α' = α" and "𝔄' = 𝔄" and "𝔅' = 𝔅"
shows "𝔉 : 𝔄' ↦↦⇩D⇩G⇩.⇩t⇩m⇘α'⇙ 𝔅'"
unfolding assms by (rule is_tm_dghm_axioms)
mk_ide rf is_tm_dghm_def[unfolded is_tm_dghm_axioms_def]
|intro is_tm_dghmI|
|dest is_tm_dghmD[dest]|
|elim is_tm_dghmE[elim]|
lemmas [dg_small_cs_intros] = is_tm_dghmD(1)
text‹Elementary properties.›
sublocale is_tm_dghm ⊆ HomDom: tiny_digraph α 𝔄
proof(rule tiny_digraphI')
show "𝔄⦇Obj⦈ ∈⇩∘ Vset α"
by (rule vdomain_in_VsetI[OF tm_dghm_ObjMap_in_Vset, simplified dg_cs_simps])
show "𝔄⦇Arr⦈ ∈⇩∘ Vset α"
by (rule vdomain_in_VsetI[OF tm_dghm_ArrMap_in_Vset, simplified dg_cs_simps])
qed (cs_concl cs_intro: dg_cs_intros)
lemmas (in is_tm_dghm)
tm_dghm_HomDom_is_tiny_digraph = HomDom.tiny_digraph_axioms
lemmas [dg_small_cs_intros] = is_tm_dghm.tm_dghm_HomDom_is_tiny_digraph
text‹Further rules.›
lemma is_tm_dghmI':
assumes "𝔉 : 𝔄 ↦↦⇩D⇩G⇘α⇙ 𝔅"
and [simp]: "𝔉⦇ObjMap⦈ ∈⇩∘ Vset α"
and [simp]: "𝔉⦇ArrMap⦈ ∈⇩∘ Vset α"
shows "𝔉 : 𝔄 ↦↦⇩D⇩G⇩.⇩t⇩m⇘α⇙ 𝔅"
proof-
interpret is_dghm α 𝔄 𝔅 𝔉 by (rule assms(1))
from assms show ?thesis
by (intro is_tm_dghmI) (auto simp: vfsequence_axioms dghm_ObjMap_vrange)
qed
text‹Size.›
lemma small_all_tm_dghms[simp]: "small {𝔉. ∃𝔄 𝔅. 𝔉 : 𝔄 ↦↦⇩D⇩G⇩.⇩t⇩m⇘α⇙ 𝔅}"
proof(rule down)
show
"{𝔉. ∃𝔄 𝔅. 𝔉 : 𝔄 ↦↦⇩D⇩G⇩.⇩t⇩m⇘α⇙ 𝔅} ⊆
elts (set {𝔉. ∃𝔄 𝔅. 𝔉 : 𝔄 ↦↦⇩D⇩G⇘α⇙ 𝔅})"
proof
(
simp only: elts_of_set small_all_dghms if_True,
rule subsetI,
unfold mem_Collect_eq
)
fix 𝔉 assume "∃𝔄 𝔅. 𝔉 : 𝔄 ↦↦⇩D⇩G⇩.⇩t⇩m⇘α⇙ 𝔅"
then obtain 𝔄 𝔅 where 𝔉: "𝔉 : 𝔄 ↦↦⇩D⇩G⇩.⇩t⇩m⇘α⇙ 𝔅" by clarsimp
interpret is_tm_dghm α 𝔄 𝔅 𝔉 by (rule 𝔉)
from is_dghm_axioms' show "∃𝔄 𝔅. 𝔉 : 𝔄 ↦↦⇩D⇩G⇘α⇙ 𝔅" by blast
qed
qed
subsubsection‹Opposite digraph homomorphism with tiny maps›
lemma (in is_tm_dghm) is_tm_dghm_op: "op_dghm 𝔉 : op_dg 𝔄 ↦↦⇩D⇩G⇩.⇩t⇩m⇘α⇙ op_dg 𝔅"
by (intro is_tm_dghmI', unfold dg_op_simps)
(cs_concl cs_intro: dg_cs_intros dg_small_cs_intros dg_op_intros)
lemma (in is_tm_dghm) is_tm_dghm_op'[dg_op_intros]:
assumes "𝔄' = op_dg 𝔄" and "𝔅' = op_dg 𝔅" and "α' = α"
shows "op_dghm 𝔉 : 𝔄' ↦↦⇩D⇩G⇩.⇩t⇩m⇘α'⇙ 𝔅'"
unfolding assms by (rule is_tm_dghm_op)
lemmas is_tm_dghm_op[dg_op_intros] = is_tm_dghm.is_tm_dghm_op'
subsubsection‹Composition of a digraph homomorphism with tiny maps›
lemma dghm_comp_is_tm_dghm[dg_small_cs_intros]:
assumes "𝔊 : 𝔅 ↦↦⇩D⇩G⇩.⇩t⇩m⇘α⇙ ℭ" and "𝔉 : 𝔄 ↦↦⇩D⇩G⇩.⇩t⇩m⇘α⇙ 𝔅"
shows "𝔊 ∘⇩D⇩G⇩H⇩M 𝔉 : 𝔄 ↦↦⇩D⇩G⇩.⇩t⇩m⇘α⇙ ℭ"
proof-
interpret 𝔉: is_tm_dghm α 𝔄 𝔅 𝔉 by (rule assms(2))
interpret 𝔊: is_tm_dghm α 𝔅 ℭ 𝔊 by (rule assms(1))
show ?thesis
proof(intro is_tm_dghmI')
from assms show "(𝔊 ∘⇩D⇩G⇩H⇩M 𝔉)⦇ObjMap⦈ ∈⇩∘ Vset α"
by
(
cs_concl
cs_simp: dghm_comp_components
cs_intro: dg_small_cs_intros Limit_vcomp_in_VsetI 𝔉.Limit_α
)+
from assms show "(𝔊 ∘⇩D⇩G⇩H⇩M 𝔉)⦇ArrMap⦈ ∈⇩∘ Vset α"
by
(
cs_concl
cs_simp: dghm_comp_components
cs_intro: dg_small_cs_intros Limit_vcomp_in_VsetI 𝔉.Limit_α
)+
qed (auto intro: dg_cs_intros)
qed
subsubsection‹Finite digraphs and digraph homomorphisms with tiny maps›
lemma (in is_dghm) dghm_is_tm_dghm_if_HomDom_finite_digraph:
assumes "finite_digraph α 𝔄"
shows "𝔉 : 𝔄 ↦↦⇩D⇩G⇩.⇩t⇩m⇘α⇙ 𝔅"
proof(intro is_tm_dghmI')
interpret 𝔄: finite_digraph α 𝔄 by (rule assms(1))
show "𝔉⦇ObjMap⦈ ∈⇩∘ Vset α"
proof(rule ObjMap.vsv_Limit_vsv_in_VsetI)
show "ℛ⇩∘ (𝔉⦇ObjMap⦈) ⊆⇩∘ Vset α"
proof-
have "ℛ⇩∘ (𝔉⦇ObjMap⦈) ⊆⇩∘ 𝔅⦇Obj⦈" by (simp add: dghm_ObjMap_vrange)
moreover have "𝔅⦇Obj⦈ ⊆⇩∘ Vset α"
by (simp add: HomCod.dg_Obj_vsubset_Vset)
ultimately show ?thesis by auto
qed
qed (auto simp: dg_cs_simps dg_small_cs_intros)
show "𝔉⦇ArrMap⦈ ∈⇩∘ Vset α"
proof(rule ArrMap.vsv_Limit_vsv_in_VsetI)
show "ℛ⇩∘ (𝔉⦇ArrMap⦈) ⊆⇩∘ Vset α"
proof-
have "ℛ⇩∘ (𝔉⦇ArrMap⦈) ⊆⇩∘ 𝔅⦇Arr⦈" by (simp add: dghm_ArrMap_vrange)
moreover have "𝔅⦇Arr⦈ ⊆⇩∘ Vset α"
by (simp add: HomCod.dg_Arr_vsubset_Vset)
ultimately show ?thesis by auto
qed
qed (auto simp: dg_cs_simps dg_small_cs_intros)
qed (simp add: dg_cs_intros)
subsubsection‹Constant digraph homomorphism›
lemma dghm_const_is_tm_dghm:
assumes "tiny_digraph α ℭ" and "digraph α 𝔇" and "f : a ↦⇘𝔇⇙ a"
shows "dghm_const ℭ 𝔇 a f : ℭ ↦↦⇩D⇩G⇩.⇩t⇩m⇘α⇙ 𝔇"
proof(intro is_tm_dghmI')
interpret ℭ: tiny_digraph α ℭ by (rule assms(1))
interpret 𝔇: digraph α 𝔇 by (rule assms(2))
from assms show "dghm_const ℭ 𝔇 a f : ℭ ↦↦⇩D⇩G⇘α⇙ 𝔇"
by (cs_concl cs_simp: dg_cs_simps cs_intro: dg_cs_intros)
show "dghm_const ℭ 𝔇 a f⦇ObjMap⦈ ∈⇩∘ Vset α"
unfolding dghm_const_components
proof(rule vbrelation.vbrelation_Limit_in_VsetI)
from assms(3) have "a ∈⇩∘ set {a}" by (cs_concl cs_intro: V_cs_intros)
with assms(3) show "ℛ⇩∘ (vconst_on (ℭ⦇Obj⦈) a) ∈⇩∘ Vset α"
by
(
cs_concl cs_intro:
dg_cs_intros
V_cs_intros
𝔇.dg_in_Obj_in_Vset
vsubset_in_VsetI
Limit_vsingleton_in_VsetI
)
show "𝒟⇩∘ (vconst_on (ℭ⦇Obj⦈) a) ∈⇩∘ Vset α"
by (cs_concl cs_simp: V_cs_simps cs_intro: V_cs_intros dg_small_cs_intros)
qed simp_all
show "dghm_const ℭ 𝔇 a f⦇ArrMap⦈ ∈⇩∘ Vset α"
unfolding dghm_const_components
proof(rule vbrelation.vbrelation_Limit_in_VsetI)
from assms(3) 𝔇.dg_Arr_vsubset_Vset show
"ℛ⇩∘ (vconst_on (ℭ⦇Arr⦈) f) ∈⇩∘ Vset α"
by (cases ‹ℭ⦇Arr⦈=0›)
(
auto
simp: dg_cs_simps 𝔇.dg_is_arrD(1)
intro!: Limit_vsingleton_in_VsetI
)
qed (auto simp: ℭ.tiny_dg_Arr_in_Vset)
qed
lemma dghm_const_is_tm_dghm'[dg_small_cs_intros]:
assumes "tiny_digraph α ℭ"
and "digraph α 𝔇"
and "f : a ↦⇘𝔇⇙ a"
and "ℭ' = ℭ"
and "𝔇' = 𝔇"
shows "dghm_const ℭ 𝔇 a f : ℭ' ↦↦⇩D⇩G⇩.⇩t⇩m⇘α⇙ 𝔇'"
using assms(1-3) unfolding assms(4,5) by (rule dghm_const_is_tm_dghm)
subsection‹Tiny digraph homomorphism›
subsubsection‹Definition and elementary properties›
locale is_tiny_dghm =
is_dghm α 𝔄 𝔅 𝔉 +
HomDom: tiny_digraph α 𝔄 +
HomCod: tiny_digraph α 𝔅
for α 𝔄 𝔅 𝔉
syntax "_is_tiny_dghm" :: "V ⇒ V ⇒ V ⇒ V ⇒ bool"
(‹(_ :/ _ ↦↦⇩D⇩G⇩.⇩t⇩i⇩n⇩yı _)› [51, 51, 51] 51)
translations "𝔉 : 𝔄 ↦↦⇩D⇩G⇩.⇩t⇩i⇩n⇩y⇘α⇙ 𝔅" ⇌ "CONST is_tiny_dghm α 𝔄 𝔅 𝔉"
abbreviation (input) is_cn_tiny_dghm :: "V ⇒ V ⇒ V ⇒ V ⇒ bool"
where "is_cn_tiny_dghm α 𝔄 𝔅 𝔉 ≡ 𝔉 : op_dg 𝔄 ↦↦⇩D⇩G⇩.⇩t⇩i⇩n⇩y⇘α⇙ 𝔅"
syntax "_is_cn_tiny_dghm" :: "V ⇒ V ⇒ V ⇒ V ⇒ bool"
(‹(_ :/ _ ⇩D⇩G⇩.⇩t⇩i⇩n⇩y↦↦ı _)› [51, 51, 51] 51)
translations "𝔉 : 𝔄 ⇩D⇩G⇩.⇩t⇩i⇩n⇩y↦↦⇘α⇙ 𝔅" ⇀ "CONST is_cn_tiny_dghm α 𝔄 𝔅 𝔉"
abbreviation all_tiny_dghms :: "V ⇒ V"
where "all_tiny_dghms α ≡ set {𝔉. ∃𝔄 𝔅. 𝔉 : 𝔄 ↦↦⇩D⇩G⇩.⇩t⇩i⇩n⇩y⇘α⇙ 𝔅}"
abbreviation small_dghms :: "V ⇒ V ⇒ V ⇒ V"
where "small_dghms α 𝔄 𝔅 ≡ set {𝔉. 𝔉 : 𝔄 ↦↦⇩D⇩G⇩.⇩t⇩i⇩n⇩y⇘α⇙ 𝔅}"
text‹Rules.›
lemma (in is_tiny_dghm) is_tiny_dghm_axioms'[dg_small_cs_intros]:
assumes "α' = α" and "𝔄' = 𝔄" and "𝔅' = 𝔅"
shows "𝔉 : 𝔄' ↦↦⇩D⇩G⇩.⇩t⇩i⇩n⇩y⇘α'⇙ 𝔅'"
unfolding assms by (rule is_tiny_dghm_axioms)
mk_ide rf is_tiny_dghm_def
|intro is_tiny_dghmI|
|dest is_tiny_dghmD[dest]|
|elim is_tiny_dghmE[elim]|
lemmas [dg_small_cs_intros] = is_tiny_dghmD(2,3)
text‹Size.›
lemma (in is_tiny_dghm) tiny_dghm_ObjMap_in_Vset[dg_small_cs_intros]:
"𝔉⦇ObjMap⦈ ∈⇩∘ Vset α"
proof-
have "𝒟⇩∘ (𝔉⦇ObjMap⦈) ∈⇩∘ Vset α"
by (simp add: dghm_ObjMap_vdomain HomDom.tiny_dg_Obj_in_Vset)
moreover from dghm_ObjMap_vrange have "ℛ⇩∘ (𝔉⦇ObjMap⦈) ∈⇩∘ Vset α"
by (simp add: vsubset_in_VsetI HomCod.tiny_dg_Obj_in_Vset)
ultimately show "𝔉⦇ObjMap⦈ ∈⇩∘ Vset α"
by
(
cs_concl cs_intro:
V_cs_intros dg_small_cs_intros ObjMap.vbrelation_Limit_in_VsetI
)
qed
lemmas [dg_small_cs_intros] = is_tiny_dghm.tiny_dghm_ObjMap_in_Vset
lemma (in is_tiny_dghm) tiny_dghm_ArrMap_in_Vset[dg_small_cs_intros]:
"𝔉⦇ArrMap⦈ ∈⇩∘ Vset α"
proof-
have "𝒟⇩∘ (𝔉⦇ArrMap⦈) ∈⇩∘ Vset α"
by (simp add: dghm_ArrMap_vdomain HomDom.tiny_dg_Arr_in_Vset)
moreover from HomCod.tiny_dg_Arr_in_Vset dghm_ArrMap_vrange have
"ℛ⇩∘ (𝔉⦇ArrMap⦈) ∈⇩∘ Vset α"
by auto
ultimately show "𝔉⦇ArrMap⦈ ∈⇩∘ Vset α"
by
(
cs_concl cs_intro:
V_cs_intros dg_small_cs_intros ArrMap.vbrelation_Limit_in_VsetI
)
qed
lemmas [dg_small_cs_intros] = is_tiny_dghm.tiny_dghm_ArrMap_in_Vset
lemma (in is_tiny_dghm) tiny_dghm_in_Vset: "𝔉 ∈⇩∘ Vset α"
proof-
note [dg_cs_intros] =
tiny_dghm_ObjMap_in_Vset
tiny_dghm_ArrMap_in_Vset
HomDom.tiny_dg_in_Vset
HomCod.tiny_dg_in_Vset
show ?thesis
by (subst dghm_def)
(cs_concl cs_simp: dg_cs_simps cs_intro: dg_cs_intros V_cs_intros)
qed
sublocale is_tiny_dghm ⊆ is_tm_dghm
by (intro is_tm_dghmI') (auto simp: dg_cs_intros dg_small_cs_intros)
lemmas (in is_tiny_dghm) tiny_dghm_is_tm_dghm = is_tm_dghm_axioms
lemmas [dg_small_cs_intros] = is_tiny_dghm.tiny_dghm_is_tm_dghm
lemma small_all_tiny_dghms[simp]: "small {𝔉. ∃𝔄 𝔅. 𝔉 : 𝔄 ↦↦⇩D⇩G⇩.⇩t⇩i⇩n⇩y⇘α⇙ 𝔅}"
proof(rule down)
show
"{𝔉. ∃𝔄 𝔅. 𝔉 : 𝔄 ↦↦⇩D⇩G⇩.⇩t⇩i⇩n⇩y⇘α⇙ 𝔅} ⊆
elts (set {𝔉. ∃𝔄 𝔅. 𝔉 : 𝔄 ↦↦⇩D⇩G⇘α⇙ 𝔅})"
proof
(
simp only: elts_of_set small_all_dghms if_True,
rule subsetI,
unfold mem_Collect_eq
)
fix 𝔉 assume "∃𝔄 𝔅. 𝔉 : 𝔄 ↦↦⇩D⇩G⇩.⇩t⇩i⇩n⇩y⇘α⇙ 𝔅"
then obtain 𝔄 𝔅 where 𝔉: "𝔉 : 𝔄 ↦↦⇩D⇩G⇩.⇩t⇩i⇩n⇩y⇘α⇙ 𝔅" by clarsimp
interpret is_tiny_dghm α 𝔄 𝔅 𝔉 by (rule 𝔉)
from is_dghm_axioms show "∃𝔄 𝔅. 𝔉 : 𝔄 ↦↦⇩D⇩G⇘α⇙ 𝔅" by auto
qed
qed
lemma tiny_dghms_vsubset_Vset[simp]:
"set {𝔉. ∃𝔄 𝔅. 𝔉 : 𝔄 ↦↦⇩D⇩G⇩.⇩t⇩i⇩n⇩y⇘α⇙ 𝔅} ⊆⇩∘ Vset α"
proof(rule vsubsetI)
fix 𝔉 assume "𝔉 ∈⇩∘ all_tiny_dghms α"
then obtain 𝔄 𝔅 where 𝔉: "𝔉 : 𝔄 ↦↦⇩D⇩G⇩.⇩t⇩i⇩n⇩y⇘α⇙ 𝔅" by clarsimp
then show "𝔉 ∈⇩∘ Vset α" by (auto simp: is_tiny_dghm.tiny_dghm_in_Vset)
qed
lemma (in is_dghm) dghm_is_tiny_dghm_if_ge_Limit:
assumes "𝒵 β" and "α ∈⇩∘ β"
shows "𝔉 : 𝔄 ↦↦⇩D⇩G⇩.⇩t⇩i⇩n⇩y⇘β⇙ 𝔅"
proof(intro is_tiny_dghmI)
interpret β: 𝒵 β by (rule assms(1))
show "𝔉 : 𝔄 ↦↦⇩D⇩G⇘β⇙ 𝔅"
by (intro dghm_is_dghm_if_ge_Limit)
(use assms(2) in ‹cs_concl cs_intro: dg_cs_intros›)+
show "tiny_digraph β 𝔄" "tiny_digraph β 𝔅"
by
(
simp_all add:
assms
HomDom.dg_tiny_digraph_if_ge_Limit
HomCod.dg_tiny_digraph_if_ge_Limit
)
qed
subsubsection‹Opposite tiny digraph homomorphism›
lemma (in is_tiny_dghm) is_tiny_dghm_op:
"op_dghm 𝔉 : op_dg 𝔄 ↦↦⇩D⇩G⇩.⇩t⇩i⇩n⇩y⇘α⇙ op_dg 𝔅"
by (intro is_tiny_dghmI)
(cs_concl cs_intro: dg_small_cs_intros dg_cs_intros dg_op_intros)+
lemma (in is_tiny_dghm) is_tiny_dghm_op'[dg_op_intros]:
assumes "𝔄' = op_dg 𝔄" and "𝔅' = op_dg 𝔅" and "α' = α"
shows "op_dghm 𝔉 : 𝔄' ↦↦⇩D⇩G⇩.⇩t⇩i⇩n⇩y⇘α'⇙ 𝔅'"
unfolding assms by (rule is_tiny_dghm_op)
lemmas is_tiny_dghm_op[dg_op_intros] = is_tiny_dghm.is_tiny_dghm_op'
subsubsection‹Composition of tiny digraph homomorphisms›
lemma dghm_comp_is_tiny_dghm[dg_small_cs_intros]:
assumes "𝔊 : 𝔅 ↦↦⇩D⇩G⇩.⇩t⇩i⇩n⇩y⇘α⇙ ℭ" and "𝔉 : 𝔄 ↦↦⇩D⇩G⇩.⇩t⇩i⇩n⇩y⇘α⇙ 𝔅"
shows "𝔊 ∘⇩D⇩G⇩H⇩M 𝔉 : 𝔄 ↦↦⇩D⇩G⇩.⇩t⇩i⇩n⇩y⇘α⇙ ℭ"
proof-
interpret 𝔉: is_tiny_dghm α 𝔄 𝔅 𝔉 by (rule assms(2))
interpret 𝔊: is_tiny_dghm α 𝔅 ℭ 𝔊 by (rule assms(1))
show ?thesis
by (intro is_tiny_dghmI)
(auto simp: dg_small_cs_intros dg_cs_simps intro: dg_cs_intros)
qed
subsubsection‹Tiny constant digraph homomorphism›
lemma dghm_const_is_tiny_dghm:
assumes "tiny_digraph α ℭ" and "tiny_digraph α 𝔇" and "f : a ↦⇘𝔇⇙ a"
shows "dghm_const ℭ 𝔇 a f : ℭ ↦↦⇩D⇩G⇩.⇩t⇩i⇩n⇩y⇘α⇙ 𝔇"
proof(intro is_tiny_dghmI)
from assms show "dghm_const ℭ 𝔇 a f : ℭ ↦↦⇩D⇩G⇘α⇙ 𝔇"
by (cs_concl cs_simp: dg_cs_simps cs_intro: dg_cs_intros dg_small_cs_intros)
qed (auto simp: assms(1,2))
lemma dghm_const_is_tiny_dghm'[dg_small_cs_intros]:
assumes "tiny_digraph α ℭ"
and "tiny_digraph α 𝔇"
and "f : a ↦⇘𝔇⇙ a"
and "ℭ' = ℭ"
and "𝔇' = 𝔇"
shows "dghm_const ℭ 𝔇 a f : ℭ' ↦↦⇩D⇩G⇩.⇩t⇩i⇩n⇩y⇘α⇙ 𝔇'"
using assms(1-3) unfolding assms(4,5) by (rule dghm_const_is_tiny_dghm)
text‹\newpage›
end
Theory CZH_DG_TDGHM
section‹Transformation of digraph homomorphisms›
theory CZH_DG_TDGHM
imports CZH_DG_DGHM
begin
subsection‹Background›
named_theorems tdghm_cs_simps
named_theorems tdghm_cs_intros
named_theorems nt_field_simps
definition NTMap :: V where [nt_field_simps]: "NTMap = 0"
definition NTDom :: V where [nt_field_simps]: "NTDom = 1⇩ℕ"
definition NTCod :: V where [nt_field_simps]: "NTCod = 2⇩ℕ"
definition NTDGDom :: V where [nt_field_simps]: "NTDGDom = 3⇩ℕ"
definition NTDGCod :: V where [nt_field_simps]: "NTDGCod = 4⇩ℕ"
subsection‹Definition and elementary properties›
text‹
A transformation of digraph homomorphisms, as presented in this work,
is a generalization of the concept of a natural transformation, as presented in
Chapter I-4 in \cite{mac_lane_categories_2010}, to digraphs and digraph
homomorphisms. The generalization is performed by excluding the commutativity
axiom from the definition.
The definition of a transformation of digraph homomorphisms is
parameterized by a limit ordinal ‹α› such that ‹ω < α›.
Such transformations of digraph homomorphisms are referred to either as
‹α›-transformations of digraph homomorphisms or
transformations of ‹α›-digraph homomorphisms.
›
locale is_tdghm =
𝒵 α +
vfsequence 𝔑 +
NTDom: is_dghm α 𝔄 𝔅 𝔉 +
NTCod: is_dghm α 𝔄 𝔅 𝔊
for α 𝔄 𝔅 𝔉 𝔊 𝔑 +
assumes tdghm_length[dg_cs_simps]: "vcard 𝔑 = 5⇩ℕ"
and tdghm_NTMap_vsv: "vsv (𝔑⦇NTMap⦈)"
and tdghm_NTMap_vdomain[dg_cs_simps]: "𝒟⇩∘ (𝔑⦇NTMap⦈) = 𝔄⦇Obj⦈"
and tdghm_NTDom[dg_cs_simps]: "𝔑⦇NTDom⦈ = 𝔉"
and tdghm_NTCod[dg_cs_simps]: "𝔑⦇NTCod⦈ = 𝔊"
and tdghm_NTDGDom[dg_cs_simps]: "𝔑⦇NTDGDom⦈ = 𝔄"
and tdghm_NTDGCod[dg_cs_simps]: "𝔑⦇NTDGCod⦈ = 𝔅"
and tdghm_NTMap_is_arr:
"a ∈⇩∘ 𝔄⦇Obj⦈ ⟹ 𝔑⦇NTMap⦈⦇a⦈ : 𝔉⦇ObjMap⦈⦇a⦈ ↦⇘𝔅⇙ 𝔊⦇ObjMap⦈⦇a⦈"
syntax "_is_tdghm" :: "V ⇒ V ⇒ V ⇒ V ⇒ V ⇒ V ⇒ bool"
(‹(_ :/ _ ↦⇩D⇩G⇩H⇩M _ :/ _ ↦↦⇩D⇩Gı _)› [51, 51, 51, 51, 51] 51)
translations "𝔑 : 𝔉 ↦⇩D⇩G⇩H⇩M 𝔊 : 𝔄 ↦↦⇩D⇩G⇘α⇙ 𝔅" ⇌
"CONST is_tdghm α 𝔄 𝔅 𝔉 𝔊 𝔑"
abbreviation all_tdghms :: "V ⇒ V"
where "all_tdghms α ≡ set {𝔑. ∃𝔉 𝔊 𝔄 𝔅. 𝔑 : 𝔉 ↦⇩D⇩G⇩H⇩M 𝔊 : 𝔄 ↦↦⇩D⇩G⇘α⇙ 𝔅}"
abbreviation tdghms :: "V ⇒ V ⇒ V ⇒ V"
where "tdghms α 𝔄 𝔅 ≡ set {𝔑. ∃𝔉 𝔊. 𝔑 : 𝔉 ↦⇩D⇩G⇩H⇩M 𝔊 : 𝔄 ↦↦⇩D⇩G⇘α⇙ 𝔅}"
abbreviation these_tdghms :: "V ⇒ V ⇒ V ⇒ V ⇒ V ⇒ V"
where "these_tdghms α 𝔄 𝔅 𝔉 𝔊 ≡ set {𝔑. 𝔑 : 𝔉 ↦⇩D⇩G⇩H⇩M 𝔊 : 𝔄 ↦↦⇩D⇩G⇘α⇙ 𝔅}"
sublocale is_tdghm ⊆ NTMap: vsv ‹𝔑⦇NTMap⦈›
rewrites "𝒟⇩∘ (𝔑⦇NTMap⦈) = 𝔄⦇Obj⦈"
by (rule tdghm_NTMap_vsv) (simp add: dg_cs_simps)
lemmas [dg_cs_simps] =
is_tdghm.tdghm_length
is_tdghm.tdghm_NTMap_vdomain
is_tdghm.tdghm_NTDom
is_tdghm.tdghm_NTCod
is_tdghm.tdghm_NTDGDom
is_tdghm.tdghm_NTDGCod
lemma (in is_tdghm) tdghm_NTMap_is_arr'[dg_cs_intros]:
assumes "a ∈⇩∘ 𝔄⦇Obj⦈"
and "A = 𝔉⦇ObjMap⦈⦇a⦈"
and "B = 𝔊⦇ObjMap⦈⦇a⦈"
shows "𝔑⦇NTMap⦈⦇a⦈ : A ↦⇘𝔅⇙ B"
using assms(1) unfolding assms(2,3) by (rule tdghm_NTMap_is_arr)
lemmas [dg_cs_intros] = is_tdghm.tdghm_NTMap_is_arr'
text‹Rules.›
lemma (in is_tdghm) is_tdghm_axioms'[dg_cs_intros]:
assumes "α' = α" and "𝔄' = 𝔄" and "𝔅' = 𝔅" and "𝔉' = 𝔉" and "𝔊' = 𝔊"
shows "𝔑 : 𝔉' ↦⇩D⇩G⇩H⇩M 𝔊' : 𝔄' ↦↦⇩D⇩G⇘α'⇙ 𝔅'"
unfolding assms by (rule is_tdghm_axioms)
mk_ide rf is_tdghm_def[unfolded is_tdghm_axioms_def]
|intro is_tdghmI|
|dest is_tdghmD[dest]|
|elim is_tdghmE[elim]|
lemmas [dg_cs_intros] =
is_tdghmD(3,4)
text‹Elementary properties.›
lemma tdghm_eqI:
assumes "𝔑 : 𝔉 ↦⇩D⇩G⇩H⇩M 𝔊 : 𝔄 ↦↦⇩D⇩G⇘α⇙ 𝔅"
and "𝔑' : 𝔉' ↦⇩D⇩G⇩H⇩M 𝔊' : 𝔄' ↦↦⇩D⇩G⇘α⇙ 𝔅'"
and "𝔑⦇NTMap⦈ = 𝔑'⦇NTMap⦈"
and "𝔉 = 𝔉'"
and "𝔊 = 𝔊'"
and "𝔄 = 𝔄'"
and "𝔅 = 𝔅'"
shows "𝔑 = 𝔑'"
proof-
interpret L: is_tdghm α 𝔄 𝔅 𝔉 𝔊 𝔑 by (rule assms(1))
interpret R: is_tdghm α 𝔄' 𝔅' 𝔉' 𝔊' 𝔑' by (rule assms(2))
show ?thesis
proof(rule vsv_eqI)
have dom: "𝒟⇩∘ 𝔑 = 5⇩ℕ" by (cs_concl cs_simp: dg_cs_simps V_cs_simps)
show "𝒟⇩∘ 𝔑 = 𝒟⇩∘ 𝔑'" by (cs_concl cs_simp: dg_cs_simps V_cs_simps)
from assms(4-7) have sup:
"𝔑⦇NTDom⦈ = 𝔑'⦇NTDom⦈" "𝔑⦇NTCod⦈ = 𝔑'⦇NTCod⦈"
"𝔑⦇NTDGDom⦈ = 𝔑'⦇NTDGDom⦈" "𝔑⦇NTDGCod⦈ = 𝔑'⦇NTDGCod⦈"
by (simp_all add: dg_cs_simps)
show "a ∈⇩∘ 𝒟⇩∘ 𝔑 ⟹ 𝔑⦇a⦈ = 𝔑'⦇a⦈" for a
by (unfold dom, elim_in_numeral, insert assms(3) sup)
(auto simp: nt_field_simps)
qed (auto simp: L.vsv_axioms R.vsv_axioms)
qed
lemma (in is_tdghm) tdghm_def:
"𝔑 = [𝔑⦇NTMap⦈, 𝔑⦇NTDom⦈, 𝔑⦇NTCod⦈, 𝔑⦇NTDGDom⦈, 𝔑⦇NTDGCod⦈]⇩∘"
proof(rule vsv_eqI)
have dom_lhs: "𝒟⇩∘ 𝔑 = 5⇩ℕ" by (cs_concl cs_simp: dg_cs_simps V_cs_simps)
have dom_rhs:
"𝒟⇩∘ [𝔑⦇NTMap⦈, 𝔑⦇NTDGDom⦈, 𝔑⦇NTDGCod⦈, 𝔑⦇NTDom⦈, 𝔑⦇NTCod⦈]⇩∘ = 5⇩ℕ"
by (simp add: nat_omega_simps)
then show
"𝒟⇩∘ 𝔑 = 𝒟⇩∘ [𝔑⦇NTMap⦈, 𝔑⦇NTDom⦈, 𝔑⦇NTCod⦈, 𝔑⦇NTDGDom⦈, 𝔑⦇NTDGCod⦈]⇩∘"
unfolding dom_lhs dom_rhs by (simp add: nat_omega_simps)
show "a ∈⇩∘ 𝒟⇩∘ 𝔑 ⟹
𝔑⦇a⦈ = [𝔑⦇NTMap⦈, 𝔑⦇NTDom⦈, 𝔑⦇NTCod⦈, 𝔑⦇NTDGDom⦈, 𝔑⦇NTDGCod⦈]⇩∘⦇a⦈"
for a
by (unfold dom_lhs, elim_in_numeral, unfold nt_field_simps)
(simp_all add: nat_omega_simps)
qed (auto simp: vsv_axioms)
lemma (in is_tdghm) tdghm_NTMap_app_in_Arr[dg_cs_intros]:
assumes "a ∈⇩∘ 𝔄⦇Obj⦈"
shows "𝔑⦇NTMap⦈⦇a⦈ ∈⇩∘ 𝔅⦇Arr⦈"
using assms using tdghm_NTMap_is_arr by auto
lemmas [dg_cs_intros] = is_tdghm.tdghm_NTMap_app_in_Arr
lemma (in is_tdghm) tdghm_NTMap_vrange_vifunion:
"ℛ⇩∘ (𝔑⦇NTMap⦈) ⊆⇩∘ (⋃⇩∘a∈⇩∘ℛ⇩∘ (𝔉⦇ObjMap⦈). ⋃⇩∘b∈⇩∘ℛ⇩∘ (𝔊⦇ObjMap⦈). Hom 𝔅 a b)"
proof(intro NTMap.vsv_vrange_vsubset)
fix x assume prems: "x ∈⇩∘ 𝔄⦇Obj⦈"
note 𝔑x = tdghm_NTMap_is_arr[OF prems]
from prems show
"𝔑⦇NTMap⦈⦇x⦈ ∈⇩∘ (⋃⇩∘a∈⇩∘ℛ⇩∘ (𝔉⦇ObjMap⦈). ⋃⇩∘b∈⇩∘ℛ⇩∘ (𝔊⦇ObjMap⦈). Hom 𝔅 a b)"
by (intro vifunionI, unfold in_Hom_iff)
(
auto intro:
dg_cs_intros NTDom.ObjMap.vsv_vimageI2' NTCod.ObjMap.vsv_vimageI2'
)
qed
lemma (in is_tdghm) tdghm_NTMap_vrange: "ℛ⇩∘ (𝔑⦇NTMap⦈) ⊆⇩∘ 𝔅⦇Arr⦈"
proof(intro NTMap.vsv_vrange_vsubset)
fix x assume "x ∈⇩∘ 𝔄⦇Obj⦈"
with is_tdghm_axioms show "𝔑⦇NTMap⦈⦇x⦈ ∈⇩∘ 𝔅⦇Arr⦈"
by (cs_concl cs_simp: dg_cs_simps cs_intro: dg_cs_intros)
qed
text‹Size.›
lemma (in is_tdghm) tdghm_NTMap_vsubset_Vset: "𝔑⦇NTMap⦈ ⊆⇩∘ Vset α"
proof(intro NTMap.vbrelation_Limit_vsubset_VsetI)
show "ℛ⇩∘ (𝔑⦇NTMap⦈) ⊆⇩∘ Vset α"
by
(
rule vsubset_transitive,
rule tdghm_NTMap_vrange,
rule NTDom.HomCod.dg_Arr_vsubset_Vset
)
qed (simp_all add: NTDom.HomDom.dg_Obj_vsubset_Vset)
lemma (in is_tdghm) tdghm_NTMap_in_Vset:
assumes "α ∈⇩∘ β"
shows "𝔑⦇NTMap⦈ ∈⇩∘ Vset β"
by (meson assms tdghm_NTMap_vsubset_Vset Vset_in_mono vsubset_in_VsetI)
lemma (in is_tdghm) tdghm_in_Vset:
assumes "𝒵 β" and "α ∈⇩∘ β"
shows "𝔑 ∈⇩∘ Vset β"
proof-
interpret β: 𝒵 β by (rule assms(1))
note [dg_cs_intros] =
tdghm_NTMap_in_Vset
NTDom.dghm_in_Vset
NTCod.dghm_in_Vset
NTDom.HomDom.dg_in_Vset
NTDom.HomCod.dg_in_Vset
from assms(2) show ?thesis
by (subst tdghm_def)
(cs_concl cs_simp: dg_cs_simps cs_intro: dg_cs_intros V_cs_intros)
qed
lemma (in is_tdghm) tdghm_is_tdghm_if_ge_Limit:
assumes "𝒵 β" and "α ∈⇩∘ β"
shows "𝔑 : 𝔉 ↦⇩D⇩G⇩H⇩M 𝔊 : 𝔄 ↦↦⇩D⇩G⇘β⇙ 𝔅"
proof(rule is_tdghmI)
show "𝔑⦇NTMap⦈⦇a⦈ : 𝔉⦇ObjMap⦈⦇a⦈ ↦⇘𝔅⇙ 𝔊⦇ObjMap⦈⦇a⦈" if "a ∈⇩∘ 𝔄⦇Obj⦈" for a
using that by (cs_concl cs_intro: dg_cs_intros)
qed
(
cs_concl
cs_simp: dg_cs_simps
cs_intro:
V_cs_intros
assms
NTDom.dghm_is_dghm_if_ge_Limit
NTCod.dghm_is_dghm_if_ge_Limit
)+
lemma small_all_tdghms[simp]:
"small {𝔑. ∃𝔉 𝔊 𝔄 𝔅. 𝔑 : 𝔉 ↦⇩D⇩G⇩H⇩M 𝔊 : 𝔄 ↦↦⇩D⇩G⇘α⇙ 𝔅}"
proof(cases ‹𝒵 α›)
case True
from is_tdghm.tdghm_in_Vset show ?thesis
by (intro down[of _ ‹Vset (α + ω)›])
(auto simp: True 𝒵.𝒵_Limit_αω 𝒵.𝒵_ω_αω 𝒵.intro 𝒵.𝒵_α_αω)
next
case False
then have "{𝔑. ∃𝔉 𝔊 𝔄 𝔅. 𝔑 : 𝔉 ↦⇩D⇩G⇩H⇩M 𝔊 : 𝔄 ↦↦⇩D⇩G⇘α⇙ 𝔅} = {}" by auto
then show ?thesis by simp
qed
lemma small_tdghms[simp]: "small {𝔑. ∃𝔉 𝔊. 𝔑 : 𝔉 ↦⇩D⇩G⇩H⇩M 𝔊 : 𝔄 ↦↦⇩D⇩G⇘α⇙ 𝔅}"
by (rule down[of _ ‹set {𝔑. ∃𝔉 𝔊 𝔄 𝔅. 𝔑 : 𝔉 ↦⇩D⇩G⇩H⇩M 𝔊 : 𝔄 ↦↦⇩D⇩G⇘α⇙ 𝔅}›])
auto
lemma small_these_tdghms[simp]: "small {𝔑. 𝔑 : 𝔉 ↦⇩D⇩G⇩H⇩M 𝔊 : 𝔄 ↦↦⇩D⇩G⇘α⇙ 𝔅}"
by (rule down[of _ ‹set {𝔑. ∃𝔉 𝔊 𝔄 𝔅. 𝔑 : 𝔉 ↦⇩D⇩G⇩H⇩M 𝔊 : 𝔄 ↦↦⇩D⇩G⇘α⇙ 𝔅}›])
auto
text‹Further elementary results.›
lemma these_tdghms_iff:
"𝔑 ∈⇩∘ these_tdghms α 𝔄 𝔅 𝔉 𝔊 ⟷ 𝔑 : 𝔉 ↦⇩D⇩G⇩H⇩M 𝔊 : 𝔄 ↦↦⇩D⇩G⇘α⇙ 𝔅"
by auto
subsection‹Opposite transformation of digraph homomorphisms›
subsubsection‹Definition and elementary properties›
text‹See section 1.5 in \cite{bodo_categories_1970}.›
definition op_tdghm :: "V ⇒ V"
where "op_tdghm 𝔑 =
[
𝔑⦇NTMap⦈,
op_dghm (𝔑⦇NTCod⦈),
op_dghm (𝔑⦇NTDom⦈),
op_dg (𝔑⦇NTDGDom⦈),
op_dg (𝔑⦇NTDGCod⦈)
]⇩∘"
text‹Components.›
lemma op_tdghm_components[dg_op_simps]:
shows "op_tdghm 𝔑⦇NTMap⦈ = 𝔑⦇NTMap⦈"
and "op_tdghm 𝔑⦇NTDom⦈ = op_dghm (𝔑⦇NTCod⦈)"
and "op_tdghm 𝔑⦇NTCod⦈ = op_dghm (𝔑⦇NTDom⦈)"
and "op_tdghm 𝔑⦇NTDGDom⦈ = op_dg (𝔑⦇NTDGDom⦈)"
and "op_tdghm 𝔑⦇NTDGCod⦈ = op_dg (𝔑⦇NTDGCod⦈)"
unfolding op_tdghm_def nt_field_simps by (auto simp: nat_omega_simps)
subsubsection‹Further properties›
lemma (in is_tdghm) is_tdghm_op:
"op_tdghm 𝔑 : op_dghm 𝔊 ↦⇩D⇩G⇩H⇩M op_dghm 𝔉 : op_dg 𝔄 ↦↦⇩D⇩G⇘α⇙ op_dg 𝔅"
proof(rule is_tdghmI, unfold dg_op_simps)
show "vfsequence (op_tdghm 𝔑)" by (simp add: op_tdghm_def)
show "vcard (op_tdghm 𝔑) = 5⇩ℕ" by (simp add: op_tdghm_def nat_omega_simps)
show "𝔑⦇NTMap⦈⦇a⦈ : 𝔉⦇ObjMap⦈⦇a⦈ ↦⇘𝔅⇙ 𝔊⦇ObjMap⦈⦇a⦈" if "a ∈⇩∘ 𝔄⦇Obj⦈" for a
using that by (cs_concl cs_intro: dg_cs_intros)
qed
(
cs_concl
cs_simp: dg_cs_simps cs_intro: dg_cs_intros dg_op_intros V_cs_intros
)+
lemma (in is_tdghm) is_tdghm_op'[dg_op_intros]:
assumes "𝔊' = op_dghm 𝔊"
and "𝔉' = op_dghm 𝔉"
and "𝔄' = op_dg 𝔄"
and "𝔅' = op_dg 𝔅"
shows "op_tdghm 𝔑 : 𝔊' ↦⇩D⇩G⇩H⇩M 𝔉' : 𝔄' ↦↦⇩D⇩G⇘α⇙ 𝔅'"
unfolding assms by (rule is_tdghm_op)
lemmas is_tdghm_op[dg_op_intros] = is_tdghm.is_tdghm_op'
lemma (in is_tdghm) tdghm_op_tdghm_op_tdghm[dg_op_simps]:
"op_tdghm (op_tdghm 𝔑) = 𝔑"
proof(rule tdghm_eqI[of α 𝔄 𝔅 𝔉 𝔊 _ 𝔄 𝔅 𝔉 𝔊], unfold dg_op_simps)
interpret op:
is_tdghm α ‹op_dg 𝔄› ‹op_dg 𝔅› ‹op_dghm 𝔊› ‹op_dghm 𝔉› ‹op_tdghm 𝔑›
by (rule is_tdghm_op)
from op.is_tdghm_op show
"op_tdghm (op_tdghm 𝔑) : 𝔉 ↦⇩D⇩G⇩H⇩M 𝔊 : 𝔄 ↦↦⇩D⇩G⇘α⇙ 𝔅"
by (simp add: dg_op_simps)
qed (auto simp: dg_cs_intros)
lemmas tdghm_op_tdghm_op_tdghm[dg_op_simps] =
is_tdghm.tdghm_op_tdghm_op_tdghm
lemma eq_op_tdghm_iff:
assumes "𝔑 : 𝔉 ↦⇩D⇩G⇩H⇩M 𝔊 : 𝔄 ↦↦⇩D⇩G⇘α⇙ 𝔅"
and "𝔑' : 𝔉' ↦⇩D⇩G⇩H⇩M 𝔊' : 𝔄' ↦↦⇩D⇩G⇘α⇙ 𝔅'"
shows "op_tdghm 𝔑 = op_tdghm 𝔑' ⟷ 𝔑 = 𝔑'"
proof
interpret L: is_tdghm α 𝔄 𝔅 𝔉 𝔊 𝔑 by (rule assms(1))
interpret R: is_tdghm α 𝔄' 𝔅' 𝔉' 𝔊' 𝔑' by (rule assms(2))
assume prems: "op_tdghm 𝔑 = op_tdghm 𝔑'"
show "𝔑 = 𝔑'"
proof(rule tdghm_eqI[OF assms])
from prems L.tdghm_op_tdghm_op_tdghm R.tdghm_op_tdghm_op_tdghm show
"𝔑⦇NTMap⦈ = 𝔑'⦇NTMap⦈"
by metis+
from prems L.tdghm_op_tdghm_op_tdghm R.tdghm_op_tdghm_op_tdghm
have "𝔑⦇NTDom⦈ = 𝔑'⦇NTDom⦈"
and "𝔑⦇NTCod⦈ = 𝔑'⦇NTCod⦈"
and "𝔑⦇NTDGDom⦈ = 𝔑'⦇NTDGDom⦈"
and "𝔑⦇NTDGCod⦈ = 𝔑'⦇NTDGCod⦈"
by metis+
then show "𝔉 = 𝔉'" "𝔊 = 𝔊'" "𝔄 = 𝔄'" "𝔅 = 𝔅'" by (auto simp: dg_cs_simps)
qed
qed auto
subsection‹
Composition of a transformation of digraph homomorphisms
and a digraph homomorphism
›
subsubsection‹Definition and elementary properties›
definition tdghm_dghm_comp :: "V ⇒ V ⇒ V" (infixl ‹∘⇩T⇩D⇩G⇩H⇩M⇩-⇩D⇩G⇩H⇩M› 55)
where "𝔑 ∘⇩T⇩D⇩G⇩H⇩M⇩-⇩D⇩G⇩H⇩M ℌ =
[
(λa∈⇩∘ℌ⦇HomDom⦈⦇Obj⦈. 𝔑⦇NTMap⦈⦇ℌ⦇ObjMap⦈⦇a⦈⦈),
𝔑⦇NTDom⦈ ∘⇩D⇩G⇩H⇩M ℌ,
𝔑⦇NTCod⦈ ∘⇩D⇩G⇩H⇩M ℌ,
ℌ⦇HomDom⦈,
𝔑⦇NTDGCod⦈
]⇩∘"
text‹Components.›
lemma tdghm_dghm_comp_components:
shows "(𝔑 ∘⇩T⇩D⇩G⇩H⇩M⇩-⇩D⇩G⇩H⇩M ℌ)⦇NTMap⦈ =
(λa∈⇩∘ℌ⦇HomDom⦈⦇Obj⦈. 𝔑⦇NTMap⦈⦇ℌ⦇ObjMap⦈⦇a⦈⦈)"
and [dg_shared_cs_simps, dg_cs_simps]:
"(𝔑 ∘⇩T⇩D⇩G⇩H⇩M⇩-⇩D⇩G⇩H⇩M ℌ)⦇NTDom⦈ = 𝔑⦇NTDom⦈ ∘⇩D⇩G⇩H⇩M ℌ"
and [dg_shared_cs_simps, dg_cs_simps]:
"(𝔑 ∘⇩T⇩D⇩G⇩H⇩M⇩-⇩D⇩G⇩H⇩M ℌ)⦇NTCod⦈ = 𝔑⦇NTCod⦈ ∘⇩D⇩G⇩H⇩M ℌ"
and [dg_shared_cs_simps, dg_cs_simps]:
"(𝔑 ∘⇩T⇩D⇩G⇩H⇩M⇩-⇩D⇩G⇩H⇩M ℌ)⦇NTDGDom⦈ = ℌ⦇HomDom⦈"
and [dg_shared_cs_simps, dg_cs_simps]:
"(𝔑 ∘⇩T⇩D⇩G⇩H⇩M⇩-⇩D⇩G⇩H⇩M ℌ)⦇NTDGCod⦈ = 𝔑⦇NTDGCod⦈"
unfolding tdghm_dghm_comp_def nt_field_simps
by (simp_all add: nat_omega_simps)
subsubsection‹Transformation map›
mk_VLambda tdghm_dghm_comp_components(1)
|vsv tdghm_dghm_comp_NTMap_vsv[dg_shared_cs_intros, dg_cs_intros]|
mk_VLambda (in is_dghm)
tdghm_dghm_comp_components(1)[where ℌ=𝔉, unfolded dghm_HomDom]
|vdomain tdghm_dghm_comp_NTMap_vdomain|
|app tdghm_dghm_comp_NTMap_app|
lemmas [dg_cs_simps] =
is_dghm.tdghm_dghm_comp_NTMap_vdomain
is_dghm.tdghm_dghm_comp_NTMap_app
lemma tdghm_dghm_comp_NTMap_vrange:
assumes "𝔑 : 𝔉 ↦⇩D⇩G⇩H⇩M 𝔊 : 𝔅 ↦↦⇩D⇩G⇘α⇙ ℭ" and "ℌ : 𝔄 ↦↦⇩D⇩G⇘α⇙ 𝔅"
shows "ℛ⇩∘ ((𝔑 ∘⇩T⇩D⇩G⇩H⇩M⇩-⇩D⇩G⇩H⇩M ℌ)⦇NTMap⦈) ⊆⇩∘ ℭ⦇Arr⦈"
proof-
interpret 𝔑: is_tdghm α 𝔅 ℭ 𝔉 𝔊 𝔑 by (rule assms(1))
interpret ℌ: is_dghm α 𝔄 𝔅 ℌ by (rule assms(2))
show ?thesis
unfolding tdghm_dghm_comp_components
proof(rule vrange_VLambda_vsubset, unfold dg_cs_simps)
fix x assume "x ∈⇩∘ 𝔄⦇Obj⦈"
then show "𝔑⦇NTMap⦈⦇ℌ⦇ObjMap⦈⦇x⦈⦈ ∈⇩∘ ℭ⦇Arr⦈"
by (cs_concl cs_intro: dg_cs_intros)
qed
qed
subsubsection‹
Opposite of the composition of a transformation of
digraph homomorphisms and a digraph homomorphism
›
lemma op_tdghm_tdghm_dghm_comp[dg_op_simps]:
"op_tdghm (𝔑 ∘⇩T⇩D⇩G⇩H⇩M⇩-⇩D⇩G⇩H⇩M ℌ) = op_tdghm 𝔑 ∘⇩T⇩D⇩G⇩H⇩M⇩-⇩D⇩G⇩H⇩M op_dghm ℌ"
unfolding
tdghm_dghm_comp_def
dghm_comp_def
op_tdghm_def
op_dghm_def
op_dg_def
dg_field_simps
dghm_field_simps
nt_field_simps
by (simp add: nat_omega_simps)
subsubsection‹
Composition of a transformation of digraph homomorphisms and a digraph
homomorphism is a transformation of digraph homomorphisms
›
lemma tdghm_dghm_comp_is_tdghm:
assumes "𝔑 : 𝔉 ↦⇩D⇩G⇩H⇩M 𝔊 : 𝔅 ↦↦⇩D⇩G⇘α⇙ ℭ" and "ℌ : 𝔄 ↦↦⇩D⇩G⇘α⇙ 𝔅"
shows "𝔑 ∘⇩T⇩D⇩G⇩H⇩M⇩-⇩D⇩G⇩H⇩M ℌ : 𝔉 ∘⇩D⇩G⇩H⇩M ℌ ↦⇩D⇩G⇩H⇩M 𝔊 ∘⇩D⇩G⇩H⇩M ℌ : 𝔄 ↦↦⇩D⇩G⇘α⇙ ℭ"
proof-
interpret 𝔑: is_tdghm α 𝔅 ℭ 𝔉 𝔊 𝔑 by (rule assms(1))
interpret ℌ: is_dghm α 𝔄 𝔅 ℌ by (rule assms(2))
show ?thesis
proof(rule is_tdghmI)
show "vfsequence (𝔑 ∘⇩T⇩D⇩G⇩H⇩M⇩-⇩D⇩G⇩H⇩M ℌ)" unfolding tdghm_dghm_comp_def by simp
show "vcard (𝔑 ∘⇩T⇩D⇩G⇩H⇩M⇩-⇩D⇩G⇩H⇩M ℌ) = 5⇩ℕ"
unfolding tdghm_dghm_comp_def by (simp add: nat_omega_simps)
show "(𝔑 ∘⇩T⇩D⇩G⇩H⇩M⇩-⇩D⇩G⇩H⇩M ℌ)⦇NTMap⦈⦇a⦈ :
(𝔉 ∘⇩D⇩G⇩H⇩M ℌ)⦇ObjMap⦈⦇a⦈ ↦⇘ℭ⇙ (𝔊 ∘⇩D⇩G⇩H⇩M ℌ)⦇ObjMap⦈⦇a⦈"
if "a ∈⇩∘ 𝔄⦇Obj⦈" for a
using that by (cs_concl cs_simp: dg_cs_simps cs_intro: dg_cs_intros)
qed (cs_concl cs_simp: dg_cs_simps cs_intro: dg_cs_intros)+
qed
lemma tdghm_dghm_comp_is_tdghm'[dg_cs_intros]:
assumes "𝔑 : 𝔉 ↦⇩D⇩G⇩H⇩M 𝔊 : 𝔅 ↦↦⇩D⇩G⇘α⇙ ℭ"
and "ℌ : 𝔄 ↦↦⇩D⇩G⇘α⇙ 𝔅"
and "𝔉' = 𝔉 ∘⇩D⇩G⇩H⇩M ℌ"
and "𝔊' = 𝔊 ∘⇩D⇩G⇩H⇩M ℌ"
shows "𝔑 ∘⇩T⇩D⇩G⇩H⇩M⇩-⇩D⇩G⇩H⇩M ℌ : 𝔉' ↦⇩D⇩G⇩H⇩M 𝔊' : 𝔄 ↦↦⇩D⇩G⇘α⇙ ℭ"
using assms(1,2) unfolding assms(3,4) by (rule tdghm_dghm_comp_is_tdghm)
subsubsection‹Further properties›
lemma tdghm_dghm_comp_tdghm_dghm_comp_assoc:
assumes "𝔑 : ℌ ↦⇩D⇩G⇩H⇩M ℌ' : ℭ ↦↦⇩D⇩G⇘α⇙ 𝔇"
and "𝔊 : 𝔅 ↦↦⇩D⇩G⇘α⇙ ℭ"
and "𝔉 : 𝔄 ↦↦⇩D⇩G⇘α⇙ 𝔅"
shows "(𝔑 ∘⇩T⇩D⇩G⇩H⇩M⇩-⇩D⇩G⇩H⇩M 𝔊) ∘⇩T⇩D⇩G⇩H⇩M⇩-⇩D⇩G⇩H⇩M 𝔉 = 𝔑 ∘⇩T⇩D⇩G⇩H⇩M⇩-⇩D⇩G⇩H⇩M (𝔊 ∘⇩D⇩G⇩H⇩M 𝔉)"
proof-
interpret 𝔑: is_tdghm α ℭ 𝔇 ℌ ℌ' 𝔑 by (rule assms(1))
interpret 𝔊: is_dghm α 𝔅 ℭ 𝔊 by (rule assms(2))
interpret 𝔉: is_dghm α 𝔄 𝔅 𝔉 by (rule assms(3))
show ?thesis
proof(rule tdghm_eqI)
from assms show
"(𝔑 ∘⇩T⇩D⇩G⇩H⇩M⇩-⇩D⇩G⇩H⇩M 𝔊) ∘⇩T⇩D⇩G⇩H⇩M⇩-⇩D⇩G⇩H⇩M 𝔉 :
ℌ ∘⇩D⇩G⇩H⇩M 𝔊 ∘⇩D⇩G⇩H⇩M 𝔉 ↦⇩D⇩G⇩H⇩M ℌ' ∘⇩D⇩G⇩H⇩M 𝔊 ∘⇩D⇩G⇩H⇩M 𝔉 :
𝔄 ↦↦⇩D⇩G⇘α⇙ 𝔇"
by (cs_concl cs_intro: dg_cs_intros)
then have dom_lhs: "𝒟⇩∘ (((𝔑 ∘⇩T⇩D⇩G⇩H⇩M⇩-⇩D⇩G⇩H⇩M 𝔊) ∘⇩T⇩D⇩G⇩H⇩M⇩-⇩D⇩G⇩H⇩M 𝔉)⦇NTMap⦈) = 𝔄⦇Obj⦈"
by (cs_concl cs_simp: dg_cs_simps)
show "𝔑 ∘⇩T⇩D⇩G⇩H⇩M⇩-⇩D⇩G⇩H⇩M (𝔊 ∘⇩D⇩G⇩H⇩M 𝔉) :
ℌ ∘⇩D⇩G⇩H⇩M 𝔊 ∘⇩D⇩G⇩H⇩M 𝔉 ↦⇩D⇩G⇩H⇩M ℌ' ∘⇩D⇩G⇩H⇩M 𝔊 ∘⇩D⇩G⇩H⇩M 𝔉 :
𝔄 ↦↦⇩D⇩G⇘α⇙ 𝔇"
by (cs_concl cs_simp: dg_cs_simps cs_intro: dg_cs_intros)
then have dom_rhs: "𝒟⇩∘ ((𝔑 ∘⇩T⇩D⇩G⇩H⇩M⇩-⇩D⇩G⇩H⇩M (𝔊 ∘⇩D⇩G⇩H⇩M 𝔉))⦇NTMap⦈) = 𝔄⦇Obj⦈"
by (cs_concl cs_simp: dg_cs_simps)
show
"((𝔑 ∘⇩T⇩D⇩G⇩H⇩M⇩-⇩D⇩G⇩H⇩M 𝔊) ∘⇩T⇩D⇩G⇩H⇩M⇩-⇩D⇩G⇩H⇩M 𝔉)⦇NTMap⦈ =
(𝔑 ∘⇩T⇩D⇩G⇩H⇩M⇩-⇩D⇩G⇩H⇩M (𝔊 ∘⇩D⇩G⇩H⇩M 𝔉))⦇NTMap⦈"
proof(rule vsv_eqI, unfold dom_lhs dom_rhs)
fix a assume "a ∈⇩∘ 𝔄⦇Obj⦈"
with assms show
"((𝔑 ∘⇩T⇩D⇩G⇩H⇩M⇩-⇩D⇩G⇩H⇩M 𝔊) ∘⇩T⇩D⇩G⇩H⇩M⇩-⇩D⇩G⇩H⇩M 𝔉)⦇NTMap⦈⦇a⦈ =
(𝔑 ∘⇩T⇩D⇩G⇩H⇩M⇩-⇩D⇩G⇩H⇩M (𝔊 ∘⇩D⇩G⇩H⇩M 𝔉))⦇NTMap⦈⦇a⦈"
by (cs_concl cs_simp: dg_cs_simps cs_intro: dg_cs_intros)
qed (cs_concl cs_intro: dg_cs_intros)
qed simp_all
qed
lemma (in is_tdghm) tdghm_tdghm_dghm_comp_dghm_id[dg_cs_simps]:
"𝔑 ∘⇩T⇩D⇩G⇩H⇩M⇩-⇩D⇩G⇩H⇩M dghm_id 𝔄 = 𝔑"
proof(rule tdghm_eqI)
show "𝔑 ∘⇩T⇩D⇩G⇩H⇩M⇩-⇩D⇩G⇩H⇩M dghm_id 𝔄 : 𝔉 ↦⇩D⇩G⇩H⇩M 𝔊 : 𝔄 ↦↦⇩D⇩G⇘α⇙ 𝔅"
by (cs_concl cs_simp: dg_cs_simps cs_intro: dg_cs_intros)
show "𝔑 : 𝔉 ↦⇩D⇩G⇩H⇩M 𝔊 : 𝔄 ↦↦⇩D⇩G⇘α⇙ 𝔅"
by (cs_concl cs_simp: dg_cs_simps cs_intro: dg_cs_intros)
have dom_lhs: "𝒟⇩∘ ((𝔑 ∘⇩T⇩D⇩G⇩H⇩M⇩-⇩D⇩G⇩H⇩M dghm_id 𝔄)⦇NTMap⦈) = 𝔄⦇Obj⦈"
by (cs_concl cs_simp: dg_cs_simps cs_intro: dg_cs_intros)
show "(𝔑 ∘⇩T⇩D⇩G⇩H⇩M⇩-⇩D⇩G⇩H⇩M dghm_id 𝔄)⦇NTMap⦈ = 𝔑⦇NTMap⦈"
proof(rule vsv_eqI, unfold dom_lhs dg_cs_simps)
fix a assume "a ∈⇩∘ 𝔄⦇Obj⦈"
then show "(𝔑 ∘⇩T⇩D⇩G⇩H⇩M⇩-⇩D⇩G⇩H⇩M dghm_id 𝔄)⦇NTMap⦈⦇a⦈ = 𝔑⦇NTMap⦈⦇a⦈"
by (cs_concl cs_simp: dg_cs_simps cs_intro: dg_cs_intros)
qed (cs_concl cs_intro: dg_cs_intros V_cs_intros)+
qed simp_all
lemmas [dg_cs_simps] = is_tdghm.tdghm_tdghm_dghm_comp_dghm_id
subsection‹
Composition of a digraph homomorphism and a transformation of
digraph homomorphisms
›
subsubsection‹Definition and elementary properties›
definition dghm_tdghm_comp :: "V ⇒ V ⇒ V" (infixl ‹∘⇩D⇩G⇩H⇩M⇩-⇩T⇩D⇩G⇩H⇩M› 55)
where "ℌ ∘⇩D⇩G⇩H⇩M⇩-⇩T⇩D⇩G⇩H⇩M 𝔑 =
[
(λa∈⇩∘𝔑⦇NTDGDom⦈⦇Obj⦈. ℌ⦇ArrMap⦈⦇𝔑⦇NTMap⦈⦇a⦈⦈),
ℌ ∘⇩D⇩G⇩H⇩M 𝔑⦇NTDom⦈,
ℌ ∘⇩D⇩G⇩H⇩M 𝔑⦇NTCod⦈,
𝔑⦇NTDGDom⦈,
ℌ⦇HomCod⦈
]⇩∘"
text‹Components.›
lemma dghm_tdghm_comp_components:
shows "(ℌ ∘⇩D⇩G⇩H⇩M⇩-⇩T⇩D⇩G⇩H⇩M 𝔑)⦇NTMap⦈ =
(λa∈⇩∘𝔑⦇NTDGDom⦈⦇Obj⦈. ℌ⦇ArrMap⦈⦇𝔑⦇NTMap⦈⦇a⦈⦈)"
and [dg_shared_cs_simps, dg_cs_simps]:
"(ℌ ∘⇩D⇩G⇩H⇩M⇩-⇩T⇩D⇩G⇩H⇩M 𝔑)⦇NTDom⦈ = ℌ ∘⇩D⇩G⇩H⇩M 𝔑⦇NTDom⦈"
and [dg_shared_cs_simps, dg_cs_simps]:
"(ℌ ∘⇩D⇩G⇩H⇩M⇩-⇩T⇩D⇩G⇩H⇩M 𝔑)⦇NTCod⦈ = ℌ ∘⇩D⇩G⇩H⇩M 𝔑⦇NTCod⦈"
and [dg_shared_cs_simps, dg_cs_simps]:
"(ℌ ∘⇩D⇩G⇩H⇩M⇩-⇩T⇩D⇩G⇩H⇩M 𝔑)⦇NTDGDom⦈ = 𝔑⦇NTDGDom⦈"
and [dg_shared_cs_simps, dg_cs_simps]:
"(ℌ ∘⇩D⇩G⇩H⇩M⇩-⇩T⇩D⇩G⇩H⇩M 𝔑)⦇NTDGCod⦈ = ℌ⦇HomCod⦈"
unfolding dghm_tdghm_comp_def nt_field_simps
by (simp_all add: nat_omega_simps)
subsubsection‹Transformation map›
mk_VLambda dghm_tdghm_comp_components(1)
|vsv dghm_tdghm_comp_NTMap_vsv[dg_shared_cs_intros, dg_cs_intros]|
mk_VLambda (in is_tdghm)
dghm_tdghm_comp_components(1)[where 𝔑=𝔑, unfolded tdghm_NTDGDom]
|vdomain dghm_tdghm_comp_NTMap_vdomain|
|app dghm_tdghm_comp_NTMap_app|
lemmas [dg_cs_simps] =
is_tdghm.dghm_tdghm_comp_NTMap_vdomain
is_tdghm.dghm_tdghm_comp_NTMap_app
lemma dghm_tdghm_comp_NTMap_vrange:
assumes "ℌ : 𝔅 ↦↦⇩D⇩G⇘α⇙ ℭ" and "𝔑 : 𝔉 ↦⇩D⇩G⇩H⇩M 𝔊 : 𝔄 ↦↦⇩D⇩G⇘α⇙ 𝔅"
shows "ℛ⇩∘ ((ℌ ∘⇩D⇩G⇩H⇩M⇩-⇩T⇩D⇩G⇩H⇩M 𝔑)⦇NTMap⦈) ⊆⇩∘ ℭ⦇Arr⦈"
proof-
interpret ℌ: is_dghm α 𝔅 ℭ ℌ by (rule assms(1))
interpret 𝔑: is_tdghm α 𝔄 𝔅 𝔉 𝔊 𝔑 by (rule assms(2))
show ?thesis
unfolding dghm_tdghm_comp_components
proof(rule vrange_VLambda_vsubset, unfold dg_cs_simps)
fix x assume "x ∈⇩∘ 𝔄⦇Obj⦈"
then show "ℌ⦇ArrMap⦈⦇𝔑⦇NTMap⦈⦇x⦈⦈ ∈⇩∘ ℭ⦇Arr⦈"
by (cs_concl cs_intro: dg_cs_intros)
qed
qed
subsubsection‹
Opposite of the composition of a digraph homomorphism
and a transformation of digraph homomorphisms
›
lemma op_tdghm_dghm_tdghm_comp[dg_op_simps]:
"op_tdghm (ℌ ∘⇩D⇩G⇩H⇩M⇩-⇩T⇩D⇩G⇩H⇩M 𝔑) = op_dghm ℌ ∘⇩D⇩G⇩H⇩M⇩-⇩T⇩D⇩G⇩H⇩M op_tdghm 𝔑"
unfolding
dghm_tdghm_comp_def
dghm_comp_def
op_tdghm_def
op_dghm_def
op_dg_def
dg_field_simps
dghm_field_simps
nt_field_simps
by (simp add: nat_omega_simps)
subsubsection‹
Composition of a digraph homomorphism and a transformation of
digraph homomorphisms is a transformation of digraph homomorphisms
›
lemma dghm_tdghm_comp_is_tdghm:
assumes "ℌ : 𝔅 ↦↦⇩D⇩G⇘α⇙ ℭ" and "𝔑 : 𝔉 ↦⇩D⇩G⇩H⇩M 𝔊 : 𝔄 ↦↦⇩D⇩G⇘α⇙ 𝔅"
shows "ℌ ∘⇩D⇩G⇩H⇩M⇩-⇩T⇩D⇩G⇩H⇩M 𝔑 : ℌ ∘⇩D⇩G⇩H⇩M 𝔉 ↦⇩D⇩G⇩H⇩M ℌ ∘⇩D⇩G⇩H⇩M 𝔊 : 𝔄 ↦↦⇩D⇩G⇘α⇙ ℭ"
proof-
interpret ℌ: is_dghm α 𝔅 ℭ ℌ by (rule assms(1))
interpret 𝔑: is_tdghm α 𝔄 𝔅 𝔉 𝔊 𝔑 by (rule assms(2))
show ?thesis
proof(rule is_tdghmI)
show "vfsequence (ℌ ∘⇩D⇩G⇩H⇩M⇩-⇩T⇩D⇩G⇩H⇩M 𝔑)"
unfolding dghm_tdghm_comp_def by simp
show "vcard (ℌ ∘⇩D⇩G⇩H⇩M⇩-⇩T⇩D⇩G⇩H⇩M 𝔑) = 5⇩ℕ"
unfolding dghm_tdghm_comp_def by (simp add: nat_omega_simps)
show "(ℌ ∘⇩D⇩G⇩H⇩M⇩-⇩T⇩D⇩G⇩H⇩M 𝔑)⦇NTMap⦈⦇a⦈ :
(ℌ ∘⇩D⇩G⇩H⇩M 𝔉)⦇ObjMap⦈⦇a⦈ ↦⇘ℭ⇙ (ℌ ∘⇩D⇩G⇩H⇩M 𝔊)⦇ObjMap⦈⦇a⦈"
if "a ∈⇩∘ 𝔄⦇Obj⦈" for a
using that by (cs_concl cs_simp: dg_cs_simps cs_intro: dg_cs_intros)
qed (cs_concl cs_simp: dg_cs_simps cs_intro: dg_cs_intros)+
qed
lemma dghm_tdghm_comp_is_tdghm'[dg_cs_intros]:
assumes "ℌ : 𝔅 ↦↦⇩D⇩G⇘α⇙ ℭ"
and "𝔑 : 𝔉 ↦⇩D⇩G⇩H⇩M 𝔊 : 𝔄 ↦↦⇩D⇩G⇘α⇙ 𝔅"
and "𝔉' = ℌ ∘⇩D⇩G⇩H⇩M 𝔉"
and "𝔊' = ℌ ∘⇩D⇩G⇩H⇩M 𝔊"
shows "ℌ ∘⇩D⇩G⇩H⇩M⇩-⇩T⇩D⇩G⇩H⇩M 𝔑 : 𝔉' ↦⇩D⇩G⇩H⇩M 𝔊' : 𝔄 ↦↦⇩D⇩G⇘α⇙ ℭ"
using assms(1,2) unfolding assms(3,4) by (rule dghm_tdghm_comp_is_tdghm)
subsubsection‹Further properties›
lemma dghm_comp_dghm_tdghm_comp_assoc:
assumes "𝔑 : ℌ ↦⇩D⇩G⇩H⇩M ℌ' : 𝔄 ↦↦⇩D⇩G⇘α⇙ 𝔅"
and "𝔉 : 𝔅 ↦↦⇩D⇩G⇘α⇙ ℭ"
and "𝔊 : ℭ ↦↦⇩D⇩G⇘α⇙ 𝔇"
shows "(𝔊 ∘⇩D⇩G⇩H⇩M 𝔉) ∘⇩D⇩G⇩H⇩M⇩-⇩T⇩D⇩G⇩H⇩M 𝔑 = 𝔊 ∘⇩D⇩G⇩H⇩M⇩-⇩T⇩D⇩G⇩H⇩M (𝔉 ∘⇩D⇩G⇩H⇩M⇩-⇩T⇩D⇩G⇩H⇩M 𝔑)"
proof(rule tdghm_eqI)
interpret 𝔑: is_tdghm α 𝔄 𝔅 ℌ ℌ' 𝔑 by (rule assms(1))
interpret 𝔉: is_dghm α 𝔅 ℭ 𝔉 by (rule assms(2))
interpret 𝔊: is_dghm α ℭ 𝔇 𝔊 by (rule assms(3))
from assms show "(𝔊 ∘⇩D⇩G⇩H⇩M 𝔉) ∘⇩D⇩G⇩H⇩M⇩-⇩T⇩D⇩G⇩H⇩M 𝔑 :
𝔊 ∘⇩D⇩G⇩H⇩M 𝔉 ∘⇩D⇩G⇩H⇩M ℌ ↦⇩D⇩G⇩H⇩M 𝔊 ∘⇩D⇩G⇩H⇩M 𝔉 ∘⇩D⇩G⇩H⇩M ℌ' : 𝔄 ↦↦⇩D⇩G⇘α⇙ 𝔇"
by (cs_concl cs_simp: dg_cs_simps cs_intro: dg_cs_intros)
then have dom_lhs: "𝒟⇩∘ ((𝔊 ∘⇩D⇩G⇩H⇩M 𝔉 ∘⇩D⇩G⇩H⇩M⇩-⇩T⇩D⇩G⇩H⇩M 𝔑)⦇NTMap⦈) = 𝔄⦇Obj⦈"
by (cs_concl cs_simp: dg_cs_simps)
from assms show "𝔊 ∘⇩D⇩G⇩H⇩M⇩-⇩T⇩D⇩G⇩H⇩M (𝔉 ∘⇩D⇩G⇩H⇩M⇩-⇩T⇩D⇩G⇩H⇩M 𝔑) :
𝔊 ∘⇩D⇩G⇩H⇩M 𝔉 ∘⇩D⇩G⇩H⇩M ℌ ↦⇩D⇩G⇩H⇩M 𝔊 ∘⇩D⇩G⇩H⇩M 𝔉 ∘⇩D⇩G⇩H⇩M ℌ' : 𝔄 ↦↦⇩D⇩G⇘α⇙ 𝔇"
by (cs_concl cs_simp: dg_cs_simps cs_intro: dg_cs_intros)
then have dom_rhs:
"𝒟⇩∘ ((𝔊 ∘⇩D⇩G⇩H⇩M⇩-⇩T⇩D⇩G⇩H⇩M (𝔉 ∘⇩D⇩G⇩H⇩M⇩-⇩T⇩D⇩G⇩H⇩M 𝔑))⦇NTMap⦈) = 𝔄⦇Obj⦈"
by (cs_concl cs_simp: dg_cs_simps)
show
"((𝔊 ∘⇩D⇩G⇩H⇩M 𝔉) ∘⇩D⇩G⇩H⇩M⇩-⇩T⇩D⇩G⇩H⇩M 𝔑)⦇NTMap⦈ =
(𝔊 ∘⇩D⇩G⇩H⇩M⇩-⇩T⇩D⇩G⇩H⇩M (𝔉 ∘⇩D⇩G⇩H⇩M⇩-⇩T⇩D⇩G⇩H⇩M 𝔑))⦇NTMap⦈"
proof(rule vsv_eqI, unfold dom_lhs dom_rhs)
fix a assume "a ∈⇩∘ 𝔄⦇Obj⦈"
then show
"(𝔊 ∘⇩D⇩G⇩H⇩M 𝔉 ∘⇩D⇩G⇩H⇩M⇩-⇩T⇩D⇩G⇩H⇩M 𝔑)⦇NTMap⦈⦇a⦈ =
(𝔊 ∘⇩D⇩G⇩H⇩M⇩-⇩T⇩D⇩G⇩H⇩M (𝔉 ∘⇩D⇩G⇩H⇩M⇩-⇩T⇩D⇩G⇩H⇩M 𝔑))⦇NTMap⦈⦇a⦈"
by (cs_concl cs_simp: dg_cs_simps cs_intro: dg_cs_intros)
qed (cs_concl cs_simp: dg_cs_simps cs_intro: dg_cs_intros)+
qed simp_all
lemma (in is_tdghm) tdghm_dghm_tdghm_comp_dghm_id[dg_cs_simps]:
"dghm_id 𝔅 ∘⇩D⇩G⇩H⇩M⇩-⇩T⇩D⇩G⇩H⇩M 𝔑 = 𝔑"
proof(rule tdghm_eqI)
show "dghm_id 𝔅 ∘⇩D⇩G⇩H⇩M⇩-⇩T⇩D⇩G⇩H⇩M 𝔑 : 𝔉 ↦⇩D⇩G⇩H⇩M 𝔊 : 𝔄 ↦↦⇩D⇩G⇘α⇙ 𝔅"
by (cs_concl cs_simp: dg_cs_simps cs_intro: dg_cs_intros)
then have dom_lhs: "𝒟⇩∘ ((dghm_id 𝔅 ∘⇩D⇩G⇩H⇩M⇩-⇩T⇩D⇩G⇩H⇩M 𝔑)⦇NTMap⦈) = 𝔄⦇Obj⦈"
by (cs_concl cs_simp: dg_cs_simps)
show "𝔑 : 𝔉 ↦⇩D⇩G⇩H⇩M 𝔊 : 𝔄 ↦↦⇩D⇩G⇘α⇙ 𝔅"
by (cs_concl cs_simp: dg_cs_simps cs_intro: dg_cs_intros)
show "(dghm_id 𝔅 ∘⇩D⇩G⇩H⇩M⇩-⇩T⇩D⇩G⇩H⇩M 𝔑)⦇NTMap⦈ = 𝔑⦇NTMap⦈"
proof(rule vsv_eqI, unfold dom_lhs dg_cs_simps)
show "vsv (𝔑⦇NTMap⦈)" by auto
fix a assume "a ∈⇩∘ 𝔄⦇Obj⦈"
then show "(dghm_id 𝔅 ∘⇩D⇩G⇩H⇩M⇩-⇩T⇩D⇩G⇩H⇩M 𝔑)⦇NTMap⦈⦇a⦈ = 𝔑⦇NTMap⦈⦇a⦈"
by (cs_concl cs_simp: dg_cs_simps cs_intro: dg_cs_intros)
qed (cs_concl cs_intro: dg_cs_intros)+
qed simp_all
lemmas [dg_cs_simps] = is_tdghm.tdghm_dghm_tdghm_comp_dghm_id
lemma dghm_tdghm_comp_tdghm_dghm_comp_assoc:
assumes "𝔑 : 𝔉 ↦⇩D⇩G⇩H⇩M 𝔊 : 𝔅 ↦↦⇩D⇩G⇘α⇙ ℭ"
and "ℌ : ℭ ↦↦⇩D⇩G⇘α⇙ 𝔇"
and "𝔎 : 𝔄 ↦↦⇩D⇩G⇘α⇙ 𝔅"
shows "(ℌ ∘⇩D⇩G⇩H⇩M⇩-⇩T⇩D⇩G⇩H⇩M 𝔑) ∘⇩T⇩D⇩G⇩H⇩M⇩-⇩D⇩G⇩H⇩M 𝔎 = ℌ ∘⇩D⇩G⇩H⇩M⇩-⇩T⇩D⇩G⇩H⇩M (𝔑 ∘⇩T⇩D⇩G⇩H⇩M⇩-⇩D⇩G⇩H⇩M 𝔎)"
proof-
interpret 𝔑: is_tdghm α 𝔅 ℭ 𝔉 𝔊 𝔑 by (rule assms(1))
interpret ℌ: is_dghm α ℭ 𝔇 ℌ by (rule assms(2))
interpret 𝔎: is_dghm α 𝔄 𝔅 𝔎 by (rule assms(3))
show ?thesis
proof(rule tdghm_eqI)
from assms have dom_lhs:
"𝒟⇩∘ (((ℌ ∘⇩D⇩G⇩H⇩M⇩-⇩T⇩D⇩G⇩H⇩M 𝔑) ∘⇩T⇩D⇩G⇩H⇩M⇩-⇩D⇩G⇩H⇩M 𝔎)⦇NTMap⦈) = 𝔄⦇Obj⦈"
by (cs_concl cs_simp: dg_cs_simps)
from assms have dom_rhs:
"𝒟⇩∘ ((ℌ ∘⇩D⇩G⇩H⇩M⇩-⇩T⇩D⇩G⇩H⇩M (𝔑 ∘⇩T⇩D⇩G⇩H⇩M⇩-⇩D⇩G⇩H⇩M 𝔎))⦇NTMap⦈) = 𝔄⦇Obj⦈"
by (cs_concl cs_simp: dg_cs_simps cs_intro: dg_cs_intros)
show
"((ℌ ∘⇩D⇩G⇩H⇩M⇩-⇩T⇩D⇩G⇩H⇩M 𝔑) ∘⇩T⇩D⇩G⇩H⇩M⇩-⇩D⇩G⇩H⇩M 𝔎)⦇NTMap⦈ =
(ℌ ∘⇩D⇩G⇩H⇩M⇩-⇩T⇩D⇩G⇩H⇩M (𝔑 ∘⇩T⇩D⇩G⇩H⇩M⇩-⇩D⇩G⇩H⇩M 𝔎))⦇NTMap⦈"
proof(rule vsv_eqI, unfold dom_lhs dom_rhs)
fix a assume "a ∈⇩∘ 𝔄⦇Obj⦈"
then show
"((ℌ ∘⇩D⇩G⇩H⇩M⇩-⇩T⇩D⇩G⇩H⇩M 𝔑) ∘⇩T⇩D⇩G⇩H⇩M⇩-⇩D⇩G⇩H⇩M 𝔎)⦇NTMap⦈⦇a⦈ =
((ℌ ∘⇩D⇩G⇩H⇩M⇩-⇩T⇩D⇩G⇩H⇩M (𝔑 ∘⇩T⇩D⇩G⇩H⇩M⇩-⇩D⇩G⇩H⇩M 𝔎)))⦇NTMap⦈⦇a⦈"
by (cs_concl cs_simp: dg_cs_simps cs_intro: dg_cs_intros)
qed (cs_concl cs_intro: dg_cs_intros)
qed (cs_concl cs_simp: dg_cs_simps cs_intro: dg_cs_intros)+
qed
text‹\newpage›
end
Theory CZH_DG_Small_TDGHM
section‹Smallness for transformations of digraph homomorphisms›
theory CZH_DG_Small_TDGHM
imports
CZH_DG_Small_DGHM
CZH_DG_TDGHM
begin
subsection‹Transformation of digraph homomorphisms with tiny maps›
subsubsection‹Definition and elementary properties›
locale is_tm_tdghm =
𝒵 α +
NTDom: is_tm_dghm α 𝔄 𝔅 𝔉 +
NTCod: is_tm_dghm α 𝔄 𝔅 𝔊 +
is_tdghm α 𝔄 𝔅 𝔉 𝔊 𝔑
for α 𝔄 𝔅 𝔉 𝔊 𝔑
syntax "_is_tm_tdghm" :: "V ⇒ V ⇒ V ⇒ V ⇒ V ⇒ V ⇒ bool"
(‹(_ :/ _ ↦⇩D⇩G⇩H⇩M⇩.⇩t⇩m _ :/ _ ↦↦⇩D⇩G⇩.⇩t⇩mı _)› [51, 51, 51, 51, 51] 51)
translations "𝔑 : 𝔉 ↦⇩D⇩G⇩H⇩M⇩.⇩t⇩m 𝔊 : 𝔄 ↦↦⇩D⇩G⇩.⇩t⇩m⇘α⇙ 𝔅" ⇌
"CONST is_tm_tdghm α 𝔄 𝔅 𝔉 𝔊 𝔑"
abbreviation all_tm_tdghms :: "V ⇒ V"
where "all_tm_tdghms α ≡
set {𝔑. ∃𝔉 𝔊 𝔄 𝔅. 𝔑 : 𝔉 ↦⇩D⇩G⇩H⇩M⇩.⇩t⇩m 𝔊 : 𝔄 ↦↦⇩D⇩G⇩.⇩t⇩m⇘α⇙ 𝔅}"
abbreviation tm_tdghms :: "V ⇒ V ⇒ V ⇒ V"
where "tm_tdghms α 𝔄 𝔅 ≡
set {𝔑. ∃𝔉 𝔊. 𝔑 : 𝔉 ↦⇩D⇩G⇩H⇩M⇩.⇩t⇩m 𝔊 : 𝔄 ↦↦⇩D⇩G⇩.⇩t⇩m⇘α⇙ 𝔅}"
abbreviation these_tm_tdghms :: "V ⇒ V ⇒ V ⇒ V ⇒ V ⇒ V"
where "these_tm_tdghms α 𝔄 𝔅 𝔉 𝔊 ≡
set {𝔑. 𝔑 : 𝔉 ↦⇩D⇩G⇩H⇩M⇩.⇩t⇩m 𝔊 : 𝔄 ↦↦⇩D⇩G⇩.⇩t⇩m⇘α⇙ 𝔅}"
text‹Rules.›
lemma (in is_tm_tdghm) is_tm_tdghm_axioms'[dg_small_cs_intros]:
assumes "α' = α" and "𝔄' = 𝔄" and "𝔅' = 𝔅" and "𝔉' = 𝔉" and "𝔊' = 𝔊"
shows "𝔑 : 𝔉' ↦⇩D⇩G⇩H⇩M⇩.⇩t⇩m 𝔊' : 𝔄' ↦↦⇩D⇩G⇩.⇩t⇩m⇘α'⇙ 𝔅'"
unfolding assms by (rule is_tm_tdghm_axioms)
mk_ide rf is_tm_tdghm_def
|intro is_tm_tdghmI|
|dest is_tm_tdghmD[dest]|
|elim is_tm_tdghmE[elim]|
lemmas [dg_small_cs_intros] = is_tm_tdghmD(2,3,4)
text‹Size.›
lemma (in is_tm_tdghm) tm_tdghm_NTMap_in_Vset: "𝔑⦇NTMap⦈ ∈⇩∘ Vset α"
proof-
show ?thesis
proof(rule vbrelation.vbrelation_Limit_in_VsetI)
have "(⋃⇩∘a∈⇩∘ℛ⇩∘ (𝔉⦇ObjMap⦈). ⋃⇩∘b∈⇩∘ℛ⇩∘ (𝔊⦇ObjMap⦈). Hom 𝔅 a b) ∈⇩∘ Vset α"
by
(
intro
NTDom.HomCod.dg_Hom_vifunion_in_Vset
NTDom.dghm_ObjMap_vrange
NTDom.tm_dghm_ObjMap_in_Vset
NTCod.dghm_ObjMap_vrange
NTCod.tm_dghm_ObjMap_in_Vset
vrange_in_VsetI
)+
moreover have
"ℛ⇩∘ (𝔑⦇NTMap⦈) ⊆⇩∘ (⋃⇩∘a∈⇩∘ℛ⇩∘ (𝔉⦇ObjMap⦈). ⋃⇩∘b∈⇩∘ℛ⇩∘ (𝔊⦇ObjMap⦈). Hom 𝔅 a b)"
by (rule tdghm_NTMap_vrange_vifunion)
ultimately show "ℛ⇩∘ (𝔑⦇NTMap⦈) ∈⇩∘ Vset α" by (auto simp: dg_cs_simps)
qed
(
insert NTCod.tm_dghm_HomDom_is_tiny_digraph,
auto intro!: NTMap.vbrelation_axioms simp: dg_cs_simps
)
qed
lemma small_all_tm_tdghms[simp]:
"small {𝔑. ∃𝔉 𝔊 𝔄 𝔅. 𝔑 : 𝔉 ↦⇩D⇩G⇩H⇩M⇩.⇩t⇩m 𝔊 : 𝔄 ↦↦⇩D⇩G⇩.⇩t⇩m⇘α⇙ 𝔅}"
proof(rule down)
show "{𝔑. ∃𝔉 𝔊 𝔄 𝔅. 𝔑 : 𝔉 ↦⇩D⇩G⇩H⇩M⇩.⇩t⇩m 𝔊 : 𝔄 ↦↦⇩D⇩G⇩.⇩t⇩m⇘α⇙ 𝔅} ⊆
elts (set {𝔑. ∃𝔉 𝔊 𝔄 𝔅. 𝔑 : 𝔉 ↦⇩D⇩G⇩H⇩M 𝔊 : 𝔄 ↦↦⇩D⇩G⇘α⇙ 𝔅})"
proof
(
simp only: elts_of_set small_all_tdghms if_True,
rule subsetI,
unfold mem_Collect_eq
)
fix 𝔑 assume "∃𝔉 𝔊 𝔄 𝔅. 𝔑 : 𝔉 ↦⇩D⇩G⇩H⇩M⇩.⇩t⇩m 𝔊 : 𝔄 ↦↦⇩D⇩G⇩.⇩t⇩m⇘α⇙ 𝔅"
then obtain 𝔉 𝔊 𝔄 𝔅 where 𝔑: "𝔑 : 𝔉 ↦⇩D⇩G⇩H⇩M⇩.⇩t⇩m 𝔊 : 𝔄 ↦↦⇩D⇩G⇩.⇩t⇩m⇘α⇙ 𝔅"
by clarsimp
interpret is_tm_tdghm α 𝔄 𝔅 𝔉 𝔊 𝔑 by (rule 𝔑)
have "𝔑 : 𝔉 ↦⇩D⇩G⇩H⇩M 𝔊 : 𝔄 ↦↦⇩D⇩G⇘α⇙ 𝔅" by (auto intro: dg_cs_intros)
then show "∃𝔉 𝔊 𝔄 𝔅. 𝔑 : 𝔉 ↦⇩D⇩G⇩H⇩M 𝔊 : 𝔄 ↦↦⇩D⇩G⇘α⇙ 𝔅" by auto
qed
qed
lemma small_tm_tdghms[simp]:
"small {𝔑. ∃𝔉 𝔊. 𝔑 : 𝔉 ↦⇩D⇩G⇩H⇩M⇩.⇩t⇩m 𝔊 : 𝔄 ↦↦⇩D⇩G⇩.⇩t⇩m⇘α⇙ 𝔅}"
by
(
rule
down[
of _ ‹set {𝔑. ∃𝔉 𝔊 𝔄 𝔅. 𝔑 : 𝔉 ↦⇩D⇩G⇩H⇩M⇩.⇩t⇩m 𝔊 : 𝔄 ↦↦⇩D⇩G⇩.⇩t⇩m⇘α⇙ 𝔅}›
]
)
auto
lemma small_these_tm_tdghms[simp]:
"small {𝔑. 𝔑 : 𝔉 ↦⇩D⇩G⇩H⇩M⇩.⇩t⇩m 𝔊 : 𝔄 ↦↦⇩D⇩G⇩.⇩t⇩m⇘α⇙ 𝔅}"
by
(
rule
down[
of _ ‹set {𝔑. ∃𝔉 𝔊 𝔄 𝔅. 𝔑 : 𝔉 ↦⇩D⇩G⇩H⇩M⇩.⇩t⇩m 𝔊 : 𝔄 ↦↦⇩D⇩G⇩.⇩t⇩m⇘α⇙ 𝔅}›
]
)
auto
text‹Further elementary results.›
lemma these_tm_tdghms_iff:
"𝔑 ∈⇩∘ these_tm_tdghms α 𝔄 𝔅 𝔉 𝔊 ⟷
𝔑 : 𝔉 ↦⇩D⇩G⇩H⇩M⇩.⇩t⇩m 𝔊 : 𝔄 ↦↦⇩D⇩G⇩.⇩t⇩m⇘α⇙ 𝔅"
by auto
subsubsection‹
Opposite transformation of digraph homomorphisms with tiny maps
›
lemma (in is_tm_tdghm) is_tm_tdghm_op:
"op_tdghm 𝔑 : op_dghm 𝔊 ↦⇩D⇩G⇩H⇩M⇩.⇩t⇩m op_dghm 𝔉 : op_dg 𝔄 ↦↦⇩D⇩G⇩.⇩t⇩m⇘α⇙ op_dg 𝔅"
by (intro is_tm_tdghmI)
(cs_concl cs_intro: dg_cs_intros dg_op_intros)+
lemma (in is_tm_tdghm) is_tm_tdghm_op'[dg_op_intros]:
assumes "𝔊' = op_dghm 𝔊"
and "𝔉' = op_dghm 𝔉"
and "𝔄' = op_dg 𝔄"
and "𝔅' = op_dg 𝔅"
shows "op_tdghm 𝔑 : 𝔊' ↦⇩D⇩G⇩H⇩M⇩.⇩t⇩m 𝔉' : 𝔄' ↦↦⇩D⇩G⇩.⇩t⇩m⇘α⇙ 𝔅'"
unfolding assms by (rule is_tm_tdghm_op)
lemmas is_tm_tdghm_op[dg_op_intros] = is_tm_tdghm.is_tm_tdghm_op'
subsubsection‹
Composition of a transformation of digraph homomorphisms with tiny
maps and a digraph homomorphism with tiny maps
›
lemma tdghm_dghm_comp_is_tm_tdghm:
assumes "𝔑 : 𝔉 ↦⇩D⇩G⇩H⇩M⇩.⇩t⇩m 𝔊 : 𝔅 ↦↦⇩D⇩G⇩.⇩t⇩m⇘α⇙ ℭ" and "ℌ : 𝔄 ↦↦⇩D⇩G⇩.⇩t⇩m⇘α⇙ 𝔅"
shows "𝔑 ∘⇩T⇩D⇩G⇩H⇩M⇩-⇩D⇩G⇩H⇩M ℌ : 𝔉 ∘⇩D⇩G⇩H⇩M ℌ ↦⇩D⇩G⇩H⇩M⇩.⇩t⇩m 𝔊 ∘⇩D⇩G⇩H⇩M ℌ : 𝔄 ↦↦⇩D⇩G⇩.⇩t⇩m⇘α⇙ ℭ"
proof-
interpret 𝔑: is_tm_tdghm α 𝔅 ℭ 𝔉 𝔊 𝔑 by (rule assms(1))
interpret ℌ: is_tm_dghm α 𝔄 𝔅 ℌ by (rule assms(2))
show ?thesis
by (rule is_tm_tdghmI)
(
cs_concl
cs_simp: dg_cs_simps cs_intro: dg_cs_intros dg_small_cs_intros
)+
qed
lemma tdghm_dghm_comp_is_tm_tdghm'[dg_small_cs_intros]:
assumes "𝔑 : 𝔉 ↦⇩D⇩G⇩H⇩M⇩.⇩t⇩m 𝔊 : 𝔅 ↦↦⇩D⇩G⇩.⇩t⇩m⇘α⇙ ℭ"
and "ℌ : 𝔄 ↦↦⇩D⇩G⇩.⇩t⇩m⇘α⇙ 𝔅"
and "𝔉' = 𝔉 ∘⇩D⇩G⇩H⇩M ℌ"
and "𝔊' = 𝔊 ∘⇩D⇩G⇩H⇩M ℌ"
shows "𝔑 ∘⇩T⇩D⇩G⇩H⇩M⇩-⇩D⇩G⇩H⇩M ℌ : 𝔉' ↦⇩D⇩G⇩H⇩M⇩.⇩t⇩m 𝔊' : 𝔄 ↦↦⇩D⇩G⇩.⇩t⇩m⇘α⇙ ℭ"
using assms(1,2) unfolding assms(3,4) by (rule tdghm_dghm_comp_is_tm_tdghm)
subsubsection‹
Composition of a digraph homomorphism with tiny maps and a
transformation of digraph homomorphisms with tiny maps
›
lemma dghm_tdghm_comp_is_tm_tdghm:
assumes "ℌ : 𝔅 ↦↦⇩D⇩G⇩.⇩t⇩m⇘α⇙ ℭ" and "𝔑 : 𝔉 ↦⇩D⇩G⇩H⇩M⇩.⇩t⇩m 𝔊 : 𝔄 ↦↦⇩D⇩G⇩.⇩t⇩m⇘α⇙ 𝔅"
shows "ℌ ∘⇩D⇩G⇩H⇩M⇩-⇩T⇩D⇩G⇩H⇩M 𝔑 : ℌ ∘⇩D⇩G⇩H⇩M 𝔉 ↦⇩D⇩G⇩H⇩M⇩.⇩t⇩m ℌ ∘⇩D⇩G⇩H⇩M 𝔊 : 𝔄 ↦↦⇩D⇩G⇩.⇩t⇩m⇘α⇙ ℭ"
proof-
interpret ℌ: is_tm_dghm α 𝔅 ℭ ℌ by (rule assms(1))
interpret 𝔑: is_tm_tdghm α 𝔄 𝔅 𝔉 𝔊 𝔑 by (rule assms(2))
show ?thesis
by (rule is_tm_tdghmI)
(
cs_concl
cs_simp: dg_cs_simps cs_intro: dg_cs_intros dg_small_cs_intros
)+
qed
lemma dghm_tdghm_comp_is_tm_tdghm'[dg_small_cs_intros]:
assumes "ℌ : 𝔅 ↦↦⇩D⇩G⇩.⇩t⇩m⇘α⇙ ℭ"
and "𝔑 : 𝔉 ↦⇩D⇩G⇩H⇩M⇩.⇩t⇩m 𝔊 : 𝔄 ↦↦⇩D⇩G⇩.⇩t⇩m⇘α⇙ 𝔅"
and "𝔉' = ℌ ∘⇩D⇩G⇩H⇩M 𝔉"
and "𝔊' = ℌ ∘⇩D⇩G⇩H⇩M 𝔊"
shows "ℌ ∘⇩D⇩G⇩H⇩M⇩-⇩T⇩D⇩G⇩H⇩M 𝔑 : 𝔉' ↦⇩D⇩G⇩H⇩M⇩.⇩t⇩m 𝔊' : 𝔄 ↦↦⇩D⇩G⇩.⇩t⇩m⇘α⇙ ℭ"
using assms(1,2) unfolding assms(3,4) by (rule dghm_tdghm_comp_is_tm_tdghm)
subsection‹Transformation of homomorphisms of tiny digraphs›
subsubsection‹Definition and elementary properties›
locale is_tiny_tdghm =
𝒵 α +
NTDom: is_tiny_dghm α 𝔄 𝔅 𝔉 +
NTCod: is_tiny_dghm α 𝔄 𝔅 𝔊 +
is_tdghm α 𝔄 𝔅 𝔉 𝔊 𝔑
for α 𝔄 𝔅 𝔉 𝔊 𝔑
syntax "_is_tiny_tdghm" :: "V ⇒ V ⇒ V ⇒ V ⇒ V ⇒ V ⇒ bool"
(‹(_ :/ _ ↦⇩D⇩G⇩H⇩M⇩.⇩t⇩i⇩n⇩y _ :/ _ ↦↦⇩D⇩G⇩.⇩t⇩i⇩n⇩yı _)› [51, 51, 51, 51, 51] 51)
translations "𝔑 : 𝔉 ↦⇩D⇩G⇩H⇩M⇩.⇩t⇩i⇩n⇩y 𝔊 : 𝔄 ↦↦⇩D⇩G⇩.⇩t⇩i⇩n⇩y⇘α⇙ 𝔅" ⇌
"CONST is_tiny_tdghm α 𝔄 𝔅 𝔉 𝔊 𝔑"
abbreviation all_tiny_tdghms :: "V ⇒ V"
where "all_tiny_tdghms α ≡
set {𝔑. ∃𝔉 𝔊 𝔄 𝔅. 𝔑 : 𝔉 ↦⇩D⇩G⇩H⇩M⇩.⇩t⇩i⇩n⇩y 𝔊 : 𝔄 ↦↦⇩D⇩G⇩.⇩t⇩i⇩n⇩y⇘α⇙ 𝔅}"
abbreviation tiny_tdghms :: "V ⇒ V ⇒ V ⇒ V"
where "tiny_tdghms α 𝔄 𝔅 ≡
set {𝔑. ∃𝔉 𝔊. 𝔑 : 𝔉 ↦⇩D⇩G⇩H⇩M⇩.⇩t⇩i⇩n⇩y 𝔊 : 𝔄 ↦↦⇩D⇩G⇩.⇩t⇩i⇩n⇩y⇘α⇙ 𝔅}"
abbreviation these_tiny_tdghms :: "V ⇒ V ⇒ V ⇒ V ⇒ V ⇒ V"
where "these_tiny_tdghms α 𝔄 𝔅 𝔉 𝔊 ≡
set {𝔑. 𝔑 : 𝔉 ↦⇩D⇩G⇩H⇩M⇩.⇩t⇩i⇩n⇩y 𝔊 : 𝔄 ↦↦⇩D⇩G⇩.⇩t⇩i⇩n⇩y⇘α⇙ 𝔅}"
text‹Rules.›
lemmas (in is_tiny_tdghm) [dg_small_cs_intros] = is_tiny_tdghm_axioms
mk_ide rf is_tiny_tdghm_def
|intro is_tiny_tdghmI[intro]|
|dest is_tiny_tdghmD[dest]|
|elim is_tiny_tdghmE[elim]|
lemmas [dg_small_cs_intros] = is_tiny_tdghmD(2,3,4)
text‹Elementary properties.›
sublocale is_tiny_tdghm ⊆ is_tm_tdghm
by (rule is_tm_tdghmI)
(auto simp: vfsequence_axioms dg_cs_intros dg_small_cs_intros)
lemmas (in is_tiny_tdghm) tiny_tdghm_is_tm_tdghm = is_tm_tdghm_axioms
lemmas [dg_small_cs_intros] = is_tiny_tdghm.tiny_tdghm_is_tm_tdghm
text‹Size.›
lemma (in is_tiny_tdghm) tiny_tdghm_in_Vset: "𝔑 ∈⇩∘ Vset α"
proof-
note [dg_cs_intros] =
tm_tdghm_NTMap_in_Vset
NTDom.tiny_dghm_in_Vset
NTCod.tiny_dghm_in_Vset
NTDom.HomDom.tiny_dg_in_Vset
NTDom.HomCod.tiny_dg_in_Vset
show ?thesis
by (subst tdghm_def)
(cs_concl cs_simp: dg_cs_simps cs_intro: dg_cs_intros V_cs_intros)
qed
lemma small_all_tiny_tdghms[simp]:
"small {𝔑. ∃𝔉 𝔊 𝔄 𝔅. 𝔑 : 𝔉 ↦⇩D⇩G⇩H⇩M⇩.⇩t⇩i⇩n⇩y 𝔊 : 𝔄 ↦↦⇩D⇩G⇩.⇩t⇩i⇩n⇩y⇘α⇙ 𝔅}"
proof(rule down)
show "{𝔑. ∃𝔉 𝔊 𝔄 𝔅. 𝔑 : 𝔉 ↦⇩D⇩G⇩H⇩M⇩.⇩t⇩i⇩n⇩y 𝔊 : 𝔄 ↦↦⇩D⇩G⇩.⇩t⇩i⇩n⇩y⇘α⇙ 𝔅} ⊆
elts (set {𝔑. ∃𝔉 𝔊 𝔄 𝔅. 𝔑 : 𝔉 ↦⇩D⇩G⇩H⇩M 𝔊 : 𝔄 ↦↦⇩D⇩G⇘α⇙ 𝔅})"
proof
(
simp only: elts_of_set small_all_tdghms if_True,
rule subsetI,
unfold mem_Collect_eq
)
fix 𝔑 assume "∃𝔉 𝔊 𝔄 𝔅. 𝔑 : 𝔉 ↦⇩D⇩G⇩H⇩M⇩.⇩t⇩i⇩n⇩y 𝔊 : 𝔄 ↦↦⇩D⇩G⇩.⇩t⇩i⇩n⇩y⇘α⇙ 𝔅"
then obtain 𝔉 𝔊 𝔄 𝔅 where 𝔑: "𝔑 : 𝔉 ↦⇩D⇩G⇩H⇩M⇩.⇩t⇩i⇩n⇩y 𝔊 : 𝔄 ↦↦⇩D⇩G⇩.⇩t⇩i⇩n⇩y⇘α⇙ 𝔅"
by clarsimp
interpret is_tiny_tdghm α 𝔄 𝔅 𝔉 𝔊 𝔑 by (rule 𝔑)
have "𝔑 : 𝔉 ↦⇩D⇩G⇩H⇩M 𝔊 : 𝔄 ↦↦⇩D⇩G⇘α⇙ 𝔅" by (auto intro: dg_cs_intros)
then show "∃𝔉 𝔊 𝔄 𝔅. 𝔑 : 𝔉 ↦⇩D⇩G⇩H⇩M 𝔊 : 𝔄 ↦↦⇩D⇩G⇘α⇙ 𝔅" by auto
qed
qed
lemma small_tiny_tdghms[simp]:
"small {𝔑. ∃𝔉 𝔊. 𝔑 : 𝔉 ↦⇩D⇩G⇩H⇩M⇩.⇩t⇩i⇩n⇩y 𝔊 : 𝔄 ↦↦⇩D⇩G⇩.⇩t⇩i⇩n⇩y⇘α⇙ 𝔅}"
by
(
rule
down[
of _ ‹set {𝔑. ∃𝔉 𝔊 𝔄 𝔅. 𝔑 : 𝔉 ↦⇩D⇩G⇩H⇩M⇩.⇩t⇩i⇩n⇩y 𝔊 : 𝔄 ↦↦⇩D⇩G⇩.⇩t⇩i⇩n⇩y⇘α⇙ 𝔅}›
]
)
auto
lemma small_these_tiny_tdghms[simp]:
"small {𝔑. 𝔑 : 𝔉 ↦⇩D⇩G⇩H⇩M⇩.⇩t⇩i⇩n⇩y 𝔊 : 𝔄 ↦↦⇩D⇩G⇩.⇩t⇩i⇩n⇩y⇘α⇙ 𝔅}"
by
(
rule
down[
of _ ‹set {𝔑. ∃𝔉 𝔊 𝔄 𝔅. 𝔑 : 𝔉 ↦⇩D⇩G⇩H⇩M⇩.⇩t⇩i⇩n⇩y 𝔊 : 𝔄 ↦↦⇩D⇩G⇩.⇩t⇩i⇩n⇩y⇘α⇙ 𝔅}›
]
)
auto
lemma tiny_tdghms_vsubset_Vset[simp]:
"set {𝔑. ∃𝔉 𝔊. 𝔑 : 𝔉 ↦⇩D⇩G⇩H⇩M⇩.⇩t⇩i⇩n⇩y 𝔊 : 𝔄 ↦↦⇩D⇩G⇩.⇩t⇩i⇩n⇩y⇘α⇙ 𝔅} ⊆⇩∘ Vset α"
(is ‹set ?tdghms ⊆⇩∘ _›)
proof(cases ‹tiny_digraph α 𝔄 ∧ tiny_digraph α 𝔅›)
case True
then have "tiny_digraph α 𝔄" and "tiny_digraph α 𝔅" by auto
show ?thesis
proof(rule vsubsetI)
fix 𝔑 assume "𝔑 ∈⇩∘ set ?tdghms"
then obtain 𝔉 𝔊 where 𝔉: "𝔑 : 𝔉 ↦⇩D⇩G⇩H⇩M⇩.⇩t⇩i⇩n⇩y 𝔊 : 𝔄 ↦↦⇩D⇩G⇩.⇩t⇩i⇩n⇩y⇘α⇙ 𝔅"
by clarsimp
interpret is_tiny_tdghm α 𝔄 𝔅 𝔉 𝔊 𝔑 by (rule 𝔉)
from tiny_tdghm_in_Vset show "𝔑 ∈⇩∘ Vset α" by simp
qed
next
case False
then have "set ?tdghms = 0" by fastforce
then show ?thesis by simp
qed
lemma (in is_tdghm) tdghm_is_tiny_tdghm_if_ge_Limit:
assumes "𝒵 β" and "α ∈⇩∘ β"
shows "𝔑 : 𝔉 ↦⇩D⇩G⇩H⇩M⇩.⇩t⇩i⇩n⇩y 𝔊 : 𝔄 ↦↦⇩D⇩G⇩.⇩t⇩i⇩n⇩y⇘β⇙ 𝔅"
proof(intro is_tiny_tdghmI)
interpret β: 𝒵 β by (rule assms(1))
show "𝔑 : 𝔉 ↦⇩D⇩G⇩H⇩M 𝔊 : 𝔄 ↦↦⇩D⇩G⇘β⇙ 𝔅"
by (intro tdghm_is_tdghm_if_ge_Limit)
(use assms(2) in ‹cs_concl cs_intro: dg_cs_intros›)+
show "𝔉 : 𝔄 ↦↦⇩D⇩G⇩.⇩t⇩i⇩n⇩y⇘β⇙ 𝔅" "𝔊 : 𝔄 ↦↦⇩D⇩G⇩.⇩t⇩i⇩n⇩y⇘β⇙ 𝔅"
by
(
simp_all add:
NTDom.dghm_is_tiny_dghm_if_ge_Limit
NTCod.dghm_is_tiny_dghm_if_ge_Limit
β.𝒵_axioms
assms(2)
)
qed (rule assms(1))
text‹Further elementary results.›
lemma these_tiny_tdghms_iff:
"𝔑 ∈⇩∘ these_tiny_tdghms α 𝔄 𝔅 𝔉 𝔊 ⟷
𝔑 : 𝔉 ↦⇩D⇩G⇩H⇩M⇩.⇩t⇩i⇩n⇩y 𝔊 : 𝔄 ↦↦⇩D⇩G⇩.⇩t⇩i⇩n⇩y⇘α⇙ 𝔅"
by auto
subsubsection‹Opposite transformation of homomorphisms of tiny digraphs›
lemma (in is_tiny_tdghm) is_tm_tdghm_op: "op_tdghm 𝔑 :
op_dghm 𝔊 ↦⇩D⇩G⇩H⇩M⇩.⇩t⇩i⇩n⇩y op_dghm 𝔉 : op_dg 𝔄 ↦↦⇩D⇩G⇩.⇩t⇩i⇩n⇩y⇘α⇙ op_dg 𝔅"
by (intro is_tiny_tdghmI)
(cs_concl cs_intro: dg_cs_intros dg_op_intros)+
lemma (in is_tiny_tdghm) is_tiny_tdghm_op'[dg_op_intros]:
assumes "𝔊' = op_dghm 𝔊"
and "𝔉' = op_dghm 𝔉"
and "𝔄' = op_dg 𝔄"
and "𝔅' = op_dg 𝔅"
shows "op_tdghm 𝔑 : 𝔊' ↦⇩D⇩G⇩H⇩M⇩.⇩t⇩i⇩n⇩y 𝔉' : 𝔄' ↦↦⇩D⇩G⇩.⇩t⇩i⇩n⇩y⇘α⇙ 𝔅'"
unfolding assms by (rule is_tm_tdghm_op)
lemmas is_tiny_tdghm_op[dg_op_intros] = is_tiny_tdghm.is_tiny_tdghm_op'
text‹\newpage›
end
Theory CZH_DG_PDigraph
section‹Product digraph›
theory CZH_DG_PDigraph
imports
CZH_DG_TDGHM
CZH_DG_Small_Digraph
begin
subsection‹Background›
text‹
The concept of a product digraph, as presented in this work,
is a generalization of the concept of a product category,
as presented in Chapter II-3 in \cite{mac_lane_categories_2010}.
›
named_theorems dg_prod_cs_simps
named_theorems dg_prod_cs_intros
subsection‹Product digraph: definition and elementary properties›
definition dg_prod :: "V ⇒ (V ⇒ V) ⇒ V"
where "dg_prod I 𝔄 =
[
(∏⇩∘i∈⇩∘I. 𝔄 i⦇Obj⦈),
(∏⇩∘i∈⇩∘I. 𝔄 i⦇Arr⦈),
(λf∈⇩∘(∏⇩∘i∈⇩∘I. 𝔄 i⦇Arr⦈). (λi∈⇩∘I. 𝔄 i⦇Dom⦈⦇f⦇i⦈⦈)),
(λf∈⇩∘(∏⇩∘i∈⇩∘I. 𝔄 i⦇Arr⦈). (λi∈⇩∘I. 𝔄 i⦇Cod⦈⦇f⦇i⦈⦈))
]⇩∘"
syntax "_PDIGRAPH" :: "pttrn ⇒ V ⇒ (V ⇒ V) ⇒ V"
(‹(3∏⇩D⇩G_∈⇩∘_./ _)› [0, 0, 10] 10)
translations "∏⇩D⇩Gi∈⇩∘I. 𝔄" ⇌ "CONST dg_prod I (λi. 𝔄)"
text‹Components.›
lemma dg_prod_components:
shows "(∏⇩D⇩Gi∈⇩∘I. 𝔄 i)⦇Obj⦈ = (∏⇩∘i∈⇩∘I. 𝔄 i⦇Obj⦈)"
and "(∏⇩D⇩Gi∈⇩∘I. 𝔄 i)⦇Arr⦈ = (∏⇩∘i∈⇩∘I. 𝔄 i⦇Arr⦈)"
and "(∏⇩D⇩Gi∈⇩∘I. 𝔄 i)⦇Dom⦈ =
(λf∈⇩∘(∏⇩∘i∈⇩∘I. 𝔄 i⦇Arr⦈). (λi∈⇩∘I. 𝔄 i⦇Dom⦈⦇f⦇i⦈⦈))"
and "(∏⇩D⇩Gi∈⇩∘I. 𝔄 i)⦇Cod⦈ =
(λf∈⇩∘(∏⇩∘i∈⇩∘I. 𝔄 i⦇Arr⦈). (λi∈⇩∘I. 𝔄 i⦇Cod⦈⦇f⦇i⦈⦈))"
unfolding dg_prod_def dg_field_simps by (simp_all add: nat_omega_simps)
subsection‹Local assumptions for a product digraph›
locale pdigraph_base = 𝒵 α for α I and 𝔄 :: "V ⇒ V" +
assumes pdg_digraphs[dg_prod_cs_intros]: "i ∈⇩∘ I ⟹ digraph α (𝔄 i)"
and pdg_index_in_Vset[dg_cs_intros]: "I ∈⇩∘ Vset α"
text‹Rules.›
lemma (in pdigraph_base) pdigraph_base_axioms'[dg_prod_cs_intros]:
assumes "α' = α" and "I' = I"
shows "pdigraph_base α' I' 𝔄"
unfolding assms by (rule pdigraph_base_axioms)
mk_ide rf pdigraph_base_def[unfolded pdigraph_base_axioms_def]
|intro pdigraph_baseI|
|dest pdigraph_baseD[dest]|
|elim pdigraph_baseE[elim]|
text‹Elementary properties.›
lemma (in pdigraph_base) pdg_Obj_in_Vset:
assumes "𝒵 β" and "α ∈⇩∘ β"
shows "(∏⇩∘i∈⇩∘I. 𝔄 i⦇Obj⦈) ∈⇩∘ Vset β"
proof(rule Vset_trans)
interpret β: 𝒵 β by (rule assms(1))
show "(∏⇩∘i∈⇩∘I. 𝔄 i⦇Obj⦈) ∈⇩∘ Vset (succ (succ α))"
proof
(
rule vsubset_in_VsetI,
rule Limit_vproduct_vsubset_Vset_succI,
rule Limit_α,
intro dg_cs_intros
)
show "Vset (succ α) ∈⇩∘ Vset (succ (succ α))"
by (cs_concl cs_intro: V_cs_intros)
fix i assume prems: "i ∈⇩∘ I"
interpret digraph α ‹𝔄 i›
using prems by (cs_concl cs_intro: dg_cs_intros dg_prod_cs_intros)
show "𝔄 i⦇Obj⦈ ⊆⇩∘ Vset α" by (rule dg_Obj_vsubset_Vset)
qed
from assms(2) show "Vset (succ (succ α)) ∈⇩∘ Vset β"
by (cs_concl cs_intro: V_cs_intros succ_in_Limit_iff[THEN iffD2])
qed
lemma (in pdigraph_base) pdg_Arr_in_Vset:
assumes "𝒵 β" and "α ∈⇩∘ β"
shows "(∏⇩∘i∈⇩∘I. 𝔄 i⦇Arr⦈) ∈⇩∘ Vset β"
proof(rule Vset_trans)
interpret β: 𝒵 β by (rule assms(1))
show "(∏⇩∘i∈⇩∘I. 𝔄 i⦇Arr⦈) ∈⇩∘ Vset (succ (succ α))"
proof
(
rule vsubset_in_VsetI,
rule Limit_vproduct_vsubset_Vset_succI,
rule Limit_α,
intro dg_cs_intros
)
fix i assume "i ∈⇩∘ I"
then interpret digraph α ‹𝔄 i›
by (cs_concl cs_intro: dg_prod_cs_intros)
show "𝔄 i⦇Arr⦈ ⊆⇩∘ Vset α" by (rule dg_Arr_vsubset_Vset)
qed (cs_concl cs_intro: V_cs_intros)
from assms(2) show "Vset (succ (succ α)) ∈⇩∘ Vset β"
by (cs_concl cs_intro: V_cs_intros succ_in_Limit_iff[THEN iffD2])
qed
lemmas_with (in pdigraph_base) [folded dg_prod_components]:
pdg_dg_prod_Obj_in_Vset[dg_cs_intros] = pdg_Obj_in_Vset
and pdg_dg_prod_Arr_in_Vset[dg_cs_intros] = pdg_Arr_in_Vset
lemma (in pdigraph_base) pdg_vsubset_index_pdigraph_base:
assumes "J ⊆⇩∘ I"
shows "pdigraph_base α J 𝔄"
using assms
by (intro pdigraph_baseI)
(auto simp: vsubset_in_VsetI dg_cs_intros intro: dg_prod_cs_intros)
subsubsection‹Object›
lemma dg_prod_ObjI:
assumes "vsv a" and "𝒟⇩∘ a = I" and "⋀i. i ∈⇩∘ I ⟹ a⦇i⦈ ∈⇩∘ 𝔄 i⦇Obj⦈"
shows "a ∈⇩∘ (∏⇩D⇩Gi∈⇩∘I. 𝔄 i)⦇Obj⦈"
using assms unfolding dg_prod_components by auto
lemma dg_prod_ObjD:
assumes "a ∈⇩∘ (∏⇩D⇩Gi∈⇩∘I. 𝔄 i)⦇Obj⦈"
shows "vsv a" and "𝒟⇩∘ a = I" and "⋀i. i ∈⇩∘ I ⟹ a⦇i⦈ ∈⇩∘ 𝔄 i⦇Obj⦈"
using assms unfolding dg_prod_components by auto
lemma dg_prod_ObjE:
assumes "a ∈⇩∘ (∏⇩D⇩Gi∈⇩∘I. 𝔄 i)⦇Obj⦈"
obtains "vsv a" and "𝒟⇩∘ a = I" and "⋀i. i ∈⇩∘ I ⟹ a⦇i⦈ ∈⇩∘ 𝔄 i⦇Obj⦈"
using assms by (auto dest: dg_prod_ObjD)
lemma dg_prod_Obj_cong:
assumes "g ∈⇩∘ (∏⇩D⇩Gi∈⇩∘I. 𝔄 i)⦇Obj⦈"
and "f ∈⇩∘ (∏⇩D⇩Gi∈⇩∘I. 𝔄 i)⦇Obj⦈"
and "⋀i. i ∈⇩∘ I ⟹ g⦇i⦈ = f⦇i⦈"
shows "g = f"
using assms by (intro vsv_eqI[of g f]) (force simp: dg_prod_components)+
subsubsection‹Arrow›
lemma dg_prod_ArrI:
assumes "vsv f" and "𝒟⇩∘ f = I" and "⋀i. i ∈⇩∘ I ⟹ f⦇i⦈ ∈⇩∘ 𝔄 i⦇Arr⦈"
shows "f ∈⇩∘ (∏⇩D⇩Gi∈⇩∘I. 𝔄 i)⦇Arr⦈"
using assms unfolding dg_prod_components by auto
lemma dg_prod_ArrD:
assumes "f ∈⇩∘ (∏⇩D⇩Gi∈⇩∘I. 𝔄 i)⦇Arr⦈"
shows "vsv f" and "𝒟⇩∘ f = I" and "⋀i. i ∈⇩∘ I ⟹ f⦇i⦈ ∈⇩∘ 𝔄 i⦇Arr⦈"
using assms unfolding dg_prod_components by auto
lemma dg_prod_ArrE:
assumes "f ∈⇩∘ (∏⇩D⇩Gi∈⇩∘I. 𝔄 i)⦇Arr⦈"
obtains "vsv f" and "𝒟⇩∘ f = I" and "⋀i. i ∈⇩∘ I ⟹ f⦇i⦈ ∈⇩∘ 𝔄 i⦇Arr⦈"
using assms by (auto dest: dg_prod_ArrD)
lemma dg_prod_Arr_cong:
assumes "g ∈⇩∘ (∏⇩D⇩Gi∈⇩∘I. 𝔄 i)⦇Arr⦈"
and "f ∈⇩∘ (∏⇩D⇩Gi∈⇩∘I. 𝔄 i)⦇Arr⦈"
and "⋀i. i ∈⇩∘ I ⟹ g⦇i⦈ = f⦇i⦈"
shows "g = f"
using assms by (intro vsv_eqI[of g f]) (force simp: dg_prod_components)+
subsubsection‹Domain›
mk_VLambda dg_prod_components(3)
|vsv dg_prod_Dom_vsv[dg_cs_intros]|
|vdomain dg_prod_Dom_vdomain[folded dg_prod_components, dg_cs_simps]|
|app dg_prod_Dom_app[folded dg_prod_components]|
lemma (in pdigraph_base) dg_prod_Dom_app_in_Obj[dg_cs_intros]:
assumes "f ∈⇩∘ (∏⇩D⇩Gi∈⇩∘I. 𝔄 i)⦇Arr⦈"
shows "(∏⇩D⇩Gi∈⇩∘I. 𝔄 i)⦇Dom⦈⦇f⦈ ∈⇩∘ (∏⇩D⇩Gi∈⇩∘I. 𝔄 i)⦇Obj⦈"
unfolding dg_prod_components(1) dg_prod_Dom_app[OF assms]
proof(intro vproductI ballI)
fix i assume prems: "i ∈⇩∘ I"
interpret digraph α ‹𝔄 i›
by (auto simp: prems intro: dg_prod_cs_intros)
from assms prems show "(λi∈⇩∘I. 𝔄 i⦇Dom⦈⦇f⦇i⦈⦈)⦇i⦈ ∈⇩∘ 𝔄 i⦇Obj⦈"
unfolding dg_prod_components(2) by force
qed simp_all
lemma dg_prod_Dom_app_component_app[dg_cs_simps]:
assumes "f ∈⇩∘ (∏⇩D⇩Gi∈⇩∘I. 𝔄 i)⦇Arr⦈" and "i ∈⇩∘ I"
shows "(∏⇩D⇩Gi∈⇩∘I. 𝔄 i)⦇Dom⦈⦇f⦈⦇i⦈ = 𝔄 i⦇Dom⦈⦇f⦇i⦈⦈"
using assms(2) unfolding dg_prod_Dom_app[OF assms(1)] by simp
subsubsection‹Codomain›
mk_VLambda dg_prod_components(4)
|vsv dg_prod_Cod_vsv[dg_cs_intros]|
|vdomain dg_prod_Cod_vdomain[folded dg_prod_components, dg_cs_simps]|
|app dg_prod_Cod_app[folded dg_prod_components]|
lemma (in pdigraph_base) dg_prod_Cod_app_in_Obj[dg_cs_intros]:
assumes "f ∈⇩∘ (∏⇩D⇩Gi∈⇩∘I. 𝔄 i)⦇Arr⦈"
shows "(∏⇩D⇩Gi∈⇩∘I. 𝔄 i)⦇Cod⦈⦇f⦈ ∈⇩∘ (∏⇩D⇩Gi∈⇩∘I. 𝔄 i)⦇Obj⦈"
unfolding dg_prod_components(1) dg_prod_Cod_app[OF assms]
proof(rule vproductI)
show "∀i∈⇩∘I. (λi∈⇩∘I. 𝔄 i⦇Cod⦈⦇f⦇i⦈⦈)⦇i⦈ ∈⇩∘ 𝔄 i⦇Obj⦈"
proof(intro ballI)
fix i assume prems: "i ∈⇩∘ I"
then interpret digraph α ‹𝔄 i›
by (auto intro: dg_prod_cs_intros)
from assms prems show "(λi∈⇩∘I. 𝔄 i⦇Cod⦈⦇f⦇i⦈⦈)⦇i⦈ ∈⇩∘ 𝔄 i⦇Obj⦈"
unfolding dg_prod_components(2) by force
qed
qed simp_all
lemma dg_prod_Cod_app_component_app[dg_cs_simps]:
assumes "f ∈⇩∘ (∏⇩D⇩Gi∈⇩∘I. 𝔄 i)⦇Arr⦈" and "i ∈⇩∘ I"
shows "(∏⇩D⇩Gi∈⇩∘I. 𝔄 i)⦇Cod⦈⦇f⦈⦇i⦈ = 𝔄 i⦇Cod⦈⦇f⦇i⦈⦈"
using assms(2) unfolding dg_prod_Cod_app[OF assms(1)] by simp
subsubsection‹A product ‹α›-digraph is a tiny ‹β›-digraph›
lemma (in pdigraph_base) pdg_tiny_digraph_dg_prod:
assumes "𝒵 β" and "α ∈⇩∘ β"
shows "tiny_digraph β (∏⇩D⇩Gi∈⇩∘I. 𝔄 i)"
proof(intro tiny_digraphI)
show "vfsequence (∏⇩D⇩Gi∈⇩∘I. 𝔄 i)" unfolding dg_prod_def by simp
show "vcard (∏⇩D⇩Gi∈⇩∘I. 𝔄 i) = 4⇩ℕ"
unfolding dg_prod_def by (simp add: nat_omega_simps)
show vsv_dg_prod_Dom: "vsv ((∏⇩D⇩Gi∈⇩∘I. 𝔄 i)⦇Dom⦈)"
unfolding dg_prod_components by simp
show vdomain_dg_prod_Dom: "𝒟⇩∘ ((∏⇩D⇩Gi∈⇩∘I. 𝔄 i)⦇Dom⦈) = (∏⇩D⇩Gi∈⇩∘I. 𝔄 i)⦇Arr⦈"
unfolding dg_prod_components by simp
show "ℛ⇩∘ ((∏⇩D⇩Gi∈⇩∘I. 𝔄 i)⦇Dom⦈) ⊆⇩∘ (∏⇩D⇩Gi∈⇩∘I. 𝔄 i)⦇Obj⦈"
by (rule vsubsetI)
(
metis
dg_prod_Dom_app_in_Obj
dg_prod_Dom_vdomain
vsv.vrange_atE
vsv_dg_prod_Dom
)
show vsv_dg_prod_Cod: "vsv ((∏⇩D⇩Gi∈⇩∘I. 𝔄 i)⦇Cod⦈)"
unfolding dg_prod_components by auto
show vdomain_dg_prod_Cod: "𝒟⇩∘ ((∏⇩D⇩Gi∈⇩∘I. 𝔄 i)⦇Cod⦈) = (∏⇩D⇩Gi∈⇩∘I. 𝔄 i)⦇Arr⦈"
unfolding dg_prod_components by auto
show "ℛ⇩∘ ((∏⇩D⇩Gi∈⇩∘I. 𝔄 i)⦇Cod⦈) ⊆⇩∘ (∏⇩D⇩Gi∈⇩∘I. 𝔄 i)⦇Obj⦈"
by (rule vsubsetI)
(
metis
dg_prod_Cod_app_in_Obj
vdomain_dg_prod_Cod
vsv.vrange_atE
vsv_dg_prod_Cod
)
qed
(
auto simp:
dg_cs_intros
assms
pdg_dg_prod_Arr_in_Vset[OF assms(1,2)]
pdg_dg_prod_Obj_in_Vset[OF assms(1,2)]
)
lemma (in pdigraph_base) pdg_tiny_digraph_dg_prod':
"tiny_digraph (α + ω) (∏⇩D⇩Gi∈⇩∘I. 𝔄 i)"
by (rule pdg_tiny_digraph_dg_prod)
(simp_all add: 𝒵_α_αω 𝒵.intro 𝒵_Limit_αω 𝒵_ω_αω)
subsubsection‹Arrow with a domain and a codomain›
lemma (in pdigraph_base) dg_prod_is_arrI:
assumes "vsv f"
and "𝒟⇩∘ f = I"
and "vsv a"
and "𝒟⇩∘ a = I"
and "vsv b"
and "𝒟⇩∘ b = I"
and "⋀i. i ∈⇩∘ I ⟹ f⦇i⦈ : a⦇i⦈ ↦⇘𝔄 i⇙ b⦇i⦈"
shows "f : a ↦⇘∏⇩D⇩Gi∈⇩∘I. 𝔄 i⇙ b"
proof(intro is_arrI)
interpret f: vsv f by (rule assms(1))
interpret a: vsv a by (rule assms(3))
interpret b: vsv b by (rule assms(5))
from assms(7) have f_components: "⋀i. i ∈⇩∘ I ⟹ f⦇i⦈ ∈⇩∘ 𝔄 i⦇Arr⦈" by auto
from assms(7) have a_components: "⋀i. i ∈⇩∘ I ⟹ a⦇i⦈ ∈⇩∘ 𝔄 i⦇Obj⦈"
by (meson digraph.dg_is_arrD(2) pdg_digraphs)
from assms(7) have b_components: "⋀i. i ∈⇩∘ I ⟹ b⦇i⦈ ∈⇩∘ 𝔄 i⦇Obj⦈"
by (meson digraph.dg_is_arrD(3) pdg_digraphs)
show f_in_Arr: "f ∈⇩∘ (∏⇩D⇩Gi∈⇩∘I. 𝔄 i)⦇Arr⦈"
unfolding dg_prod_components
by (intro vproductI)
(auto simp: f_components assms(2) f.vsv_vrange_vsubset_vifunion_app)
show "(∏⇩D⇩Gi∈⇩∘I. 𝔄 i)⦇Dom⦈⦇f⦈ = a"
proof(rule vsv_eqI)
from dg_prod_Dom_app_in_Obj[OF f_in_Arr] show "vsv ((∏⇩D⇩Gi∈⇩∘I. 𝔄 i)⦇Dom⦈⦇f⦈)"
unfolding dg_prod_components by clarsimp
from dg_prod_Dom_app_in_Obj[OF f_in_Arr] assms(4) show [simp]:
"𝒟⇩∘ ((∏⇩D⇩Gi∈⇩∘I. 𝔄 i)⦇Dom⦈⦇f⦈) = 𝒟⇩∘ a"
unfolding dg_prod_components by clarsimp
fix i assume "i ∈⇩∘ 𝒟⇩∘ ((∏⇩D⇩Gi∈⇩∘I. 𝔄 i)⦇Dom⦈⦇f⦈)"
then have i: "i ∈⇩∘ I" by (simp add: assms(4))
from a_components assms(7) i show "(∏⇩D⇩Gi∈⇩∘I. 𝔄 i)⦇Dom⦈⦇f⦈⦇i⦈ = a⦇i⦈"
unfolding dg_prod_Dom_app_component_app[OF f_in_Arr i] by auto
qed auto
show "(∏⇩D⇩Gi∈⇩∘I. 𝔄 i)⦇Cod⦈⦇f⦈ = b"
proof(rule vsv_eqI)
from dg_prod_Cod_app_in_Obj[OF f_in_Arr] show "vsv ((∏⇩D⇩Gi∈⇩∘I. 𝔄 i)⦇Cod⦈⦇f⦈)"
unfolding dg_prod_components by clarsimp
from dg_prod_Cod_app_in_Obj[OF f_in_Arr] assms(6) show [simp]:
"𝒟⇩∘ ((∏⇩D⇩Gi∈⇩∘I. 𝔄 i)⦇Cod⦈⦇f⦈) = 𝒟⇩∘ b"
unfolding dg_prod_components by clarsimp
fix i assume "i ∈⇩∘ 𝒟⇩∘ ((∏⇩D⇩Gi∈⇩∘I. 𝔄 i)⦇Cod⦈⦇f⦈)"
then have i: "i ∈⇩∘ I" by (simp add: assms(6))
from b_components assms(7) i show "(∏⇩D⇩Gi∈⇩∘I. 𝔄 i)⦇Cod⦈⦇f⦈⦇i⦈ = b⦇i⦈"
unfolding dg_prod_Cod_app_component_app[OF f_in_Arr i] by auto
qed auto
qed
lemma (in pdigraph_base) dg_prod_is_arrD[dest]:
assumes "f : a ↦⇘∏⇩D⇩Gi∈⇩∘I. 𝔄 i⇙ b"
shows "vsv f"
and "𝒟⇩∘ f = I"
and "vsv a"
and "𝒟⇩∘ a = I"
and "vsv b"
and "𝒟⇩∘ b = I"
and "⋀i. i ∈⇩∘ I ⟹ f⦇i⦈ : a⦇i⦈ ↦⇘𝔄 i⇙ b⦇i⦈"
proof-
from is_arrD[OF assms] have f: "f ∈⇩∘ (∏⇩D⇩Gi∈⇩∘I. 𝔄 i)⦇Arr⦈"
and a: "a ∈⇩∘ (∏⇩D⇩Gi∈⇩∘I. 𝔄 i)⦇Obj⦈"
and b: "b ∈⇩∘ (∏⇩D⇩Gi∈⇩∘I. 𝔄 i)⦇Obj⦈"
by (auto intro: dg_cs_intros)
then show "𝒟⇩∘ f = I" "𝒟⇩∘ a = I" "𝒟⇩∘ b = I" "vsv f" "vsv a" "vsv b"
unfolding dg_prod_components by auto
fix i assume prems: "i ∈⇩∘ I"
show "f⦇i⦈ : a⦇i⦈ ↦⇘𝔄 i⇙ b⦇i⦈"
proof(intro is_arrI)
from assms(1) have f: "f ∈⇩∘ (∏⇩D⇩Gi∈⇩∘I. 𝔄 i)⦇Arr⦈"
and a: "a ∈⇩∘ (∏⇩D⇩Gi∈⇩∘I. 𝔄 i)⦇Obj⦈"
and b: "b ∈⇩∘ (∏⇩D⇩Gi∈⇩∘I. 𝔄 i)⦇Obj⦈"
by (auto intro: dg_cs_intros)
from f prems show "f⦇i⦈ ∈⇩∘ 𝔄 i⦇Arr⦈"
unfolding dg_prod_components by clarsimp
from a b assms(1) prems dg_prod_components(2,3,4) show
"𝔄 i⦇Dom⦈⦇f⦇i⦈⦈ = a⦇i⦈" "𝔄 i⦇Cod⦈⦇f⦇i⦈⦈ = b⦇i⦈"
by fastforce+
qed
qed
lemma (in pdigraph_base) dg_prod_is_arrE[elim]:
assumes "f : a ↦⇘∏⇩D⇩Gi∈⇩∘I. 𝔄 i⇙ b"
obtains "vsv f"
and "𝒟⇩∘ f = I"
and "vsv a"
and "𝒟⇩∘ a = I"
and "vsv b"
and "𝒟⇩∘ b = I"
and "⋀i. i ∈⇩∘ I ⟹ f⦇i⦈ : a⦇i⦈ ↦⇘𝔄 i⇙ b⦇i⦈"
using assms by auto
subsection‹Further local assumptions for product digraphs›
subsubsection‹Definition and elementary properties›
locale pdigraph = pdigraph_base α I 𝔄 for α I 𝔄 +
assumes pdg_Obj_vsubset_Vset: "J ⊆⇩∘ I ⟹ (∏⇩D⇩Gi∈⇩∘J. 𝔄 i)⦇Obj⦈ ⊆⇩∘ Vset α"
and pdg_Hom_vifunion_in_Vset:
"⟦
J ⊆⇩∘ I;
A ⊆⇩∘ (∏⇩D⇩Gi∈⇩∘J. 𝔄 i)⦇Obj⦈;
B ⊆⇩∘ (∏⇩D⇩Gi∈⇩∘J. 𝔄 i)⦇Obj⦈;
A ∈⇩∘ Vset α;
B ∈⇩∘ Vset α
⟧ ⟹ (⋃⇩∘a∈⇩∘A. ⋃⇩∘b∈⇩∘B. Hom (∏⇩D⇩Gi∈⇩∘J. 𝔄 i) a b) ∈⇩∘ Vset α"
text‹Rules.›
lemma (in pdigraph) pdigraph_axioms'[dg_prod_cs_intros]:
assumes "α' = α" and "I' = I"
shows "pdigraph α' I' 𝔄"
unfolding assms by (rule pdigraph_axioms)
mk_ide rf pdigraph_def[unfolded pdigraph_axioms_def]
|intro pdigraphI|
|dest pdigraphD[dest]|
|elim pdigraphE[elim]|
lemmas [dg_prod_cs_intros] = pdigraphD(1)
text‹Elementary properties.›
lemma (in pdigraph) pdg_Obj_vsubset_Vset': "(∏⇩D⇩Gi∈⇩∘I. 𝔄 i)⦇Obj⦈ ⊆⇩∘ Vset α"
by (rule pdg_Obj_vsubset_Vset) simp
lemma (in pdigraph) pdg_Hom_vifunion_in_Vset':
assumes "A ⊆⇩∘ (∏⇩D⇩Gi∈⇩∘I. 𝔄 i)⦇Obj⦈"
and "B ⊆⇩∘ (∏⇩D⇩Gi∈⇩∘I. 𝔄 i)⦇Obj⦈"
and "A ∈⇩∘ Vset α"
and "B ∈⇩∘ Vset α"
shows "(⋃⇩∘a∈⇩∘A. ⋃⇩∘b∈⇩∘B. Hom (∏⇩D⇩Gi∈⇩∘I. 𝔄 i) a b) ∈⇩∘ Vset α"
using assms by (intro pdg_Hom_vifunion_in_Vset) simp_all
lemma (in pdigraph) pdg_vsubset_index_pdigraph:
assumes "J ⊆⇩∘ I"
shows "pdigraph α J 𝔄"
proof(intro pdigraphI)
show "dg_prod J' 𝔄⦇Obj⦈ ⊆⇩∘ Vset α" if ‹J' ⊆⇩∘ J› for J'
proof-
from that assms have "J' ⊆⇩∘ I" by simp
then show "dg_prod J' 𝔄⦇Obj⦈ ⊆⇩∘ Vset α" by (rule pdg_Obj_vsubset_Vset)
qed
fix A B J' assume prems:
"J' ⊆⇩∘ J"
"A ⊆⇩∘ (∏⇩D⇩Gi∈⇩∘J'. 𝔄 i)⦇Obj⦈"
"B ⊆⇩∘ (∏⇩D⇩Gi∈⇩∘J'. 𝔄 i)⦇Obj⦈"
"A ∈⇩∘ Vset α"
"B ∈⇩∘ Vset α"
show "(⋃⇩∘a∈⇩∘A. ⋃⇩∘b∈⇩∘B. Hom (∏⇩D⇩Gi∈⇩∘J'. 𝔄 i) a b) ∈⇩∘ Vset α"
proof-
from prems(1) assms have "J' ⊆⇩∘ I" by simp
from pdg_Hom_vifunion_in_Vset[OF this prems(2-5)] show ?thesis.
qed
qed (rule pdg_vsubset_index_pdigraph_base[OF assms])
subsubsection‹A product ‹α›-digraph is an ‹α›-digraph›
lemma (in pdigraph) pdg_digraph_dg_prod: "digraph α (∏⇩D⇩Gi∈⇩∘I. 𝔄 i)"
proof-
interpret tiny_digraph ‹α + ω› ‹∏⇩D⇩Gi∈⇩∘I. 𝔄 i›
by (intro pdg_tiny_digraph_dg_prod)
(auto simp: 𝒵_α_αω 𝒵.intro 𝒵_Limit_αω 𝒵_ω_αω)
show ?thesis
by (rule digraph_if_digraph)
(
auto
intro!: pdg_Hom_vifunion_in_Vset pdg_Obj_vsubset_Vset
intro: dg_cs_intros
)
qed
subsection‹Local assumptions for a finite product digraph›
subsubsection‹Definition and elementary properties›
locale finite_pdigraph = pdigraph_base α I 𝔄 for α I 𝔄 +
assumes fin_pdg_index_vfinite: "vfinite I"
text‹Rules.›
lemma (in finite_pdigraph) finite_pdigraph_axioms'[dg_prod_cs_intros]:
assumes "α' = α" and "I' = I"
shows "finite_pdigraph α' I' 𝔄"
unfolding assms by (rule finite_pdigraph_axioms)
mk_ide rf finite_pdigraph_def[unfolded finite_pdigraph_axioms_def]
|intro finite_pdigraphI|
|dest finite_pdigraphD[dest]|
|elim finite_pdigraphE[elim]|
lemmas [dg_prod_cs_intros] = finite_pdigraphD(1)
subsubsection‹
Local assumptions for a finite product digraph and local
assumptions for an arbitrary product digraph
›
sublocale finite_pdigraph ⊆ pdigraph α I 𝔄
proof(intro pdigraphI)
show "(∏⇩D⇩Gi∈⇩∘J. 𝔄 i)⦇Obj⦈ ⊆⇩∘ Vset α" if "J ⊆⇩∘ I" for J
unfolding dg_prod_components
proof-
from that fin_pdg_index_vfinite have J: "vfinite J"
by (cs_concl cs_intro: vfinite_vsubset)
show "(∏⇩∘i∈⇩∘J. 𝔄 i⦇Obj⦈) ⊆⇩∘ Vset α"
proof(intro vsubsetI)
fix A assume prems: "A ∈⇩∘ (∏⇩∘i∈⇩∘J. 𝔄 i⦇Obj⦈)"
note A = vproductD[OF prems, rule_format]
show "A ∈⇩∘ Vset α"
proof(rule vsv.vsv_Limit_vsv_in_VsetI)
from that show "𝒟⇩∘ A ∈⇩∘ Vset α"
unfolding A(2) by (auto intro: pdg_index_in_Vset)
show "ℛ⇩∘ A ⊆⇩∘ Vset α"
proof(intro vsv.vsv_vrange_vsubset, unfold A(2))
fix i assume prems': "i ∈⇩∘ J"
with that have i: "i ∈⇩∘ I" by auto
interpret digraph α ‹𝔄 i›
by (cs_concl cs_intro: dg_prod_cs_intros i)
have "A⦇i⦈ ∈⇩∘ 𝔄 i⦇Obj⦈" by (rule A(3)[OF prems'])
then show "A⦇i⦈ ∈⇩∘ Vset α" by (cs_concl cs_intro: dg_cs_intros)
qed (intro A(1))
qed (auto simp: A(2) intro!: J A(1))
qed
qed
show "(⋃⇩∘a∈⇩∘A. ⋃⇩∘b∈⇩∘B. Hom (∏⇩D⇩Gi∈⇩∘J. 𝔄 i) a b) ∈⇩∘ Vset α"
if J: "J ⊆⇩∘ I"
and A: "A ⊆⇩∘ (∏⇩D⇩Gi∈⇩∘J. 𝔄 i)⦇Obj⦈"
and B: "B ⊆⇩∘ (∏⇩D⇩Gi∈⇩∘J. 𝔄 i)⦇Obj⦈"
and A_in_Vset: "A ∈⇩∘ Vset α"
and B_in_Vset: "B ∈⇩∘ Vset α"
for J A B
proof-
interpret J: pdigraph_base α J 𝔄
by (intro J pdg_vsubset_index_pdigraph_base)
let ?UA = ‹⋃⇩∘(⋃⇩∘(⋃⇩∘A))› and ?UB = ‹⋃⇩∘(⋃⇩∘(⋃⇩∘B))›
from that(4) have UA: "?UA ∈⇩∘ Vset α" by (intro VUnion_in_VsetI)
from that(5) have UB: "?UB ∈⇩∘ Vset α" by (intro VUnion_in_VsetI)
have "(∏⇩∘i∈⇩∘J. (⋃⇩∘a∈⇩∘?UA. ⋃⇩∘b∈⇩∘?UB. Hom (𝔄 i) a b)) ∈⇩∘ Vset α"
proof(intro Limit_vproduct_in_VsetI)
from that(1) show "J ∈⇩∘ Vset α" by (auto intro!: pdg_index_in_Vset)
show "(⋃⇩∘a∈⇩∘?UA. ⋃⇩∘b∈⇩∘?UB. Hom (𝔄 i) a b) ∈⇩∘ Vset α" if i: "i ∈⇩∘ J" for i
proof-
from i J have i: "i ∈⇩∘ I" by auto
interpret digraph α ‹𝔄 i›
using i by (cs_concl cs_intro: dg_prod_cs_intros)
have [dg_cs_simps]: "(⋃⇩∘a∈⇩∘?UA. ⋃⇩∘b∈⇩∘?UB. Hom (𝔄 i) a b) ⊆⇩∘
(⋃⇩∘a∈⇩∘?UA ∩⇩∘ 𝔄 i⦇Obj⦈. ⋃⇩∘b∈⇩∘?UB ∩⇩∘ 𝔄 i⦇Obj⦈. Hom (𝔄 i) a b)"
proof(intro vsubsetI)
fix f assume "f ∈⇩∘ (⋃⇩∘a∈⇩∘?UA. ⋃⇩∘b∈⇩∘?UB. Hom (𝔄 i) a b)"
then obtain a b
where a: "a ∈⇩∘ ?UA" and b: "b ∈⇩∘ ?UB" and f: "f : a ↦⇘𝔄 i⇙ b"
by (elim vifunionE, unfold in_Hom_iff)
then show
"f ∈⇩∘ (⋃⇩∘a∈⇩∘?UA ∩⇩∘ 𝔄 i⦇Obj⦈. ⋃⇩∘b∈⇩∘?UB ∩⇩∘ 𝔄 i⦇Obj⦈. Hom (𝔄 i) a b)"
by (intro vifunionI, unfold in_Hom_iff) (auto intro!: f b a)
qed
moreover from UA UB have
"(⋃⇩∘a∈⇩∘?UA ∩⇩∘ 𝔄 i⦇Obj⦈. ⋃⇩∘b∈⇩∘?UB ∩⇩∘ 𝔄 i⦇Obj⦈. Hom (𝔄 i) a b) ∈⇩∘
Vset α"
by (intro dg_Hom_vifunion_in_Vset) auto
ultimately show ?thesis by auto
qed
from J show "vfinite J"
by (rule vfinite_vsubset[OF fin_pdg_index_vfinite])
qed auto
moreover have
"(⋃⇩∘a∈⇩∘A. ⋃⇩∘b∈⇩∘B. Hom (∏⇩D⇩Gi∈⇩∘J. 𝔄 i) a b) ⊆⇩∘
(∏⇩∘i∈⇩∘J. (⋃⇩∘a∈⇩∘?UA. ⋃⇩∘b∈⇩∘?UB. Hom (𝔄 i) a b))"
proof(intro vsubsetI)
fix f assume "f ∈⇩∘ (⋃⇩∘a∈⇩∘A. ⋃⇩∘b∈⇩∘B. Hom (∏⇩D⇩Gi∈⇩∘J. 𝔄 i) a b)"
then obtain a b
where a: "a ∈⇩∘ A" and b: "b ∈⇩∘ B" and f: "f ∈⇩∘ Hom (∏⇩D⇩Gi∈⇩∘J. 𝔄 i) a b"
by auto
from f have f: "f : a ↦⇘(∏⇩D⇩Gi∈⇩∘J. 𝔄 i)⇙ b" by simp
show "f ∈⇩∘ (∏⇩∘i∈⇩∘J. (⋃⇩∘a∈⇩∘?UA. ⋃⇩∘b∈⇩∘?UB. Hom (𝔄 i) a b))"
proof
(
intro vproductI,
unfold Ball_def;
(intro allI impI)?;
(intro vifunionI)?;
(unfold in_Hom_iff)?
)
from f show "vsv f" by (auto simp: dg_prod_components(2))
from f show "𝒟⇩∘ f = J" by (auto simp: dg_prod_components(2))
fix i assume i: "i ∈⇩∘ J"
show "a⦇i⦈ ∈⇩∘ ?UA"
by
(
intro vprojection_in_VUnionI,
rule that(2)[unfolded dg_prod_components(1)];
intro a i
)
show "b⦇i⦈ ∈⇩∘ ?UB"
by
(
intro vprojection_in_VUnionI,
rule that(3)[unfolded dg_prod_components(1)];
intro b i
)
show "f⦇i⦈ : a⦇i⦈ ↦⇘𝔄 i⇙ b⦇i⦈" by (rule J.dg_prod_is_arrD(7)[OF f i])
qed
qed
ultimately show "(⋃⇩∘a∈⇩∘A. ⋃⇩∘b∈⇩∘B. Hom (∏⇩D⇩Gi∈⇩∘J. 𝔄 i) a b) ∈⇩∘ Vset α"
by blast
qed
qed (intro pdigraph_base_axioms)
subsection‹Binary union and complement›
subsubsection‹Application-specific methods›
method vdiff_of_vunion uses rule assms subset =
(
rule
rule
[
OF vintersection_complement assms,
unfolded vunion_complement[OF subset]
]
)
method vdiff_of_vunion' uses rule assms subset =
(
rule
rule
[
OF vintersection_complement complement_vsubset subset assms,
unfolded vunion_complement[OF subset]
]
)
subsubsection‹Results›
lemma dg_prod_vunion_Obj_in_Obj:
assumes "vdisjnt J K"
and "b ∈⇩∘ (∏⇩D⇩Gj∈⇩∘J. 𝔄 j)⦇Obj⦈"
and "c ∈⇩∘ (∏⇩D⇩Gk∈⇩∘K. 𝔄 k)⦇Obj⦈"
shows "b ∪⇩∘ c ∈⇩∘ (∏⇩D⇩Gi∈⇩∘J ∪⇩∘ K. 𝔄 i)⦇Obj⦈"
proof-
interpret b: vsv b using assms(2) unfolding dg_prod_components by clarsimp
interpret c: vsv c using assms(3) unfolding dg_prod_components by clarsimp
from assms(2,3) have dom_b: "𝒟⇩∘ b = J" and dom_c: "𝒟⇩∘ c = K"
unfolding dg_prod_components by auto
from assms(1) have disjnt: "𝒟⇩∘ b ∩⇩∘ 𝒟⇩∘ c = 0" unfolding dom_b dom_c by auto
show ?thesis
unfolding dg_prod_components
proof(intro vproductI)
show "𝒟⇩∘ (b ∪⇩∘ c) = J ∪⇩∘ K" by (auto simp: vdomain_vunion dom_b dom_c)
show "∀i∈⇩∘J ∪⇩∘ K. (b ∪⇩∘ c)⦇i⦈ ∈⇩∘ 𝔄 i⦇Obj⦈"
proof(intro ballI)
fix i assume prems: "i ∈⇩∘ J ∪⇩∘ K"
then consider (ib) ‹i ∈⇩∘ 𝒟⇩∘ b› | (ic) ‹i ∈⇩∘ 𝒟⇩∘ c›
unfolding dom_b dom_c by auto
then show "(b ∪⇩∘ c)⦇i⦈ ∈⇩∘ 𝔄 i⦇Obj⦈"
proof cases
case ib
with prems disjnt have bc_i: "(b ∪⇩∘ c)⦇i⦈ = b⦇i⦈"
by (auto intro!: vsv_vunion_app_left)
from assms(2) ib show ?thesis unfolding bc_i dg_prod_components by auto
next
case ic
with prems disjnt have bc_i: "(b ∪⇩∘ c)⦇i⦈ = c⦇i⦈"
by (auto intro!: vsv_vunion_app_right)
from assms(3) ic show ?thesis unfolding bc_i dg_prod_components by auto
qed
qed
qed (auto simp: disjnt)
qed
lemma dg_prod_vdiff_vunion_Obj_in_Obj:
assumes "J ⊆⇩∘ I"
and "b ∈⇩∘ (∏⇩D⇩Gk∈⇩∘I -⇩∘ J. 𝔄 k)⦇Obj⦈"
and "c ∈⇩∘ (∏⇩D⇩Gj∈⇩∘J. 𝔄 j)⦇Obj⦈"
shows "b ∪⇩∘ c ∈⇩∘ (∏⇩D⇩Gi∈⇩∘I. 𝔄 i)⦇Obj⦈"
by
(
vdiff_of_vunion
rule: dg_prod_vunion_Obj_in_Obj assms: assms(2,3) subset: assms(1)
)
lemma dg_prod_vunion_Arr_in_Arr:
assumes "vdisjnt J K"
and "b ∈⇩∘ (∏⇩D⇩Gj∈⇩∘J. 𝔄 j)⦇Arr⦈"
and "c ∈⇩∘ (∏⇩D⇩Gk∈⇩∘K. 𝔄 k)⦇Arr⦈"
shows "b ∪⇩∘ c ∈⇩∘ (∏⇩D⇩Gi∈⇩∘J ∪⇩∘ K. 𝔄 i)⦇Arr⦈"
unfolding dg_prod_components
proof(intro vproductI)
interpret b: vsv b using assms(2) unfolding dg_prod_components by clarsimp
interpret c: vsv c using assms(3) unfolding dg_prod_components by clarsimp
from assms have dom_b: "𝒟⇩∘ b = J" and dom_c: "𝒟⇩∘ c = K"
unfolding dg_prod_components by auto
from assms have disjnt: "𝒟⇩∘ b ∩⇩∘ 𝒟⇩∘ c = 0" unfolding dom_b dom_c by auto
from disjnt show "vsv (b ∪⇩∘ c)" by auto
show dom_bc: "𝒟⇩∘ (b ∪⇩∘ c) = J ∪⇩∘ K"
unfolding vdomain_vunion dom_b dom_c by auto
show "∀i∈⇩∘J ∪⇩∘ K. (b ∪⇩∘ c)⦇i⦈ ∈⇩∘ 𝔄 i⦇Arr⦈"
proof(intro ballI)
fix i assume prems: "i ∈⇩∘ J ∪⇩∘ K"
then consider (ib) ‹i ∈⇩∘ 𝒟⇩∘ b› | (ic) ‹i ∈⇩∘ 𝒟⇩∘ c›
unfolding dom_b dom_c by auto
then show "(b ∪⇩∘ c)⦇i⦈ ∈⇩∘ 𝔄 i⦇Arr⦈"
proof cases
case ib
with prems disjnt have bc_i: "(b ∪⇩∘ c)⦇i⦈ = b⦇i⦈"
by (auto intro!: vsv_vunion_app_left)
from assms(2) ib show ?thesis unfolding bc_i dg_prod_components by auto
next
case ic
with prems disjnt have bc_i: "(b ∪⇩∘ c)⦇i⦈ = c⦇i⦈"
by (auto intro!: vsv_vunion_app_right)
from assms(3) ic show ?thesis unfolding bc_i dg_prod_components by auto
qed
qed
qed
lemma dg_prod_vdiff_vunion_Arr_in_Arr:
assumes "J ⊆⇩∘ I"
and "b ∈⇩∘ (∏⇩D⇩Gk∈⇩∘I -⇩∘ J. 𝔄 k)⦇Arr⦈"
and "c ∈⇩∘ (∏⇩D⇩Gj∈⇩∘J. 𝔄 j)⦇Arr⦈"
shows "b ∪⇩∘ c ∈⇩∘ (∏⇩D⇩Gi∈⇩∘I. 𝔄 i)⦇Arr⦈"
by
(
vdiff_of_vunion
rule: dg_prod_vunion_Arr_in_Arr assms: assms(2,3) subset: assms(1)
)
lemma (in pdigraph) pdg_dg_prod_vunion_is_arr:
assumes "vdisjnt J K"
and "J ⊆⇩∘ I"
and "K ⊆⇩∘ I"
and "g : a ↦⇘(∏⇩D⇩Gj∈⇩∘J. 𝔄 j)⇙ b"
and "f : c ↦⇘(∏⇩D⇩Gk∈⇩∘K. 𝔄 k)⇙ d"
shows "g ∪⇩∘ f : a ∪⇩∘ c ↦⇘(∏⇩D⇩Gi∈⇩∘J ∪⇩∘ K. 𝔄 i)⇙ b ∪⇩∘ d"
proof-
interpret J𝔄: pdigraph α J 𝔄
using assms(2) by (simp add: pdg_vsubset_index_pdigraph)
interpret K𝔄: pdigraph α K 𝔄
using assms(3) by (simp add: pdg_vsubset_index_pdigraph)
interpret JK𝔄: pdigraph α ‹J ∪⇩∘ K› 𝔄
using assms(2,3) by (simp add: pdg_vsubset_index_pdigraph)
show ?thesis
proof(intro JK𝔄.dg_prod_is_arrI)
note gD = J𝔄.dg_prod_is_arrD[OF assms(4)]
and fD = K𝔄.dg_prod_is_arrD[OF assms(5)]
from assms(1) gD fD show
"vsv (g ∪⇩∘ f)"
"𝒟⇩∘ (g ∪⇩∘ f) = J ∪⇩∘ K"
"vsv (a ∪⇩∘ c)"
"𝒟⇩∘ (a ∪⇩∘ c) = J ∪⇩∘ K"
"vsv (b ∪⇩∘ d)"
"𝒟⇩∘ (b ∪⇩∘ d) = J ∪⇩∘ K"
by (auto simp: vdomain_vunion)
fix i assume "i ∈⇩∘ J ∪⇩∘ K"
then consider (iJ) ‹i ∈⇩∘ J› | (iK) ‹i ∈⇩∘ K› by auto
then show "(g ∪⇩∘ f)⦇i⦈ : (a ∪⇩∘ c)⦇i⦈ ↦⇘𝔄 i⇙ (b ∪⇩∘ d)⦇i⦈"
proof cases
case iJ
have gf_i: "(g ∪⇩∘ f)⦇i⦈ = g⦇i⦈" by (simp add: iJ assms(1) gD(1,2) fD(1,2))
have ac_i: "(a ∪⇩∘ c)⦇i⦈ = a⦇i⦈" by (simp add: iJ assms(1) gD(3,4) fD(3,4))
have bd_i: "(b ∪⇩∘ d)⦇i⦈ = b⦇i⦈" by (simp add: iJ assms(1) gD(5,6) fD(5,6))
show ?thesis unfolding gf_i ac_i bd_i by (rule gD(7)[OF iJ])
next
case iK
have gf_i: "(g ∪⇩∘ f)⦇i⦈ = f⦇i⦈" by (simp add: iK assms(1) gD(1,2) fD(1,2))
have ac_i: "(a ∪⇩∘ c)⦇i⦈ = c⦇i⦈" by (simp add: iK assms(1) gD(3,4) fD(3,4))
have bd_i: "(b ∪⇩∘ d)⦇i⦈ = d⦇i⦈" by (simp add: iK assms(1) gD(5,6) fD(5,6))
show ?thesis unfolding gf_i ac_i bd_i by (rule fD(7)[OF iK])
qed
qed
qed
lemma (in pdigraph) pdg_dg_prod_vdiff_vunion_is_arr:
assumes "J ⊆⇩∘ I"
and "g : a ↦⇘(∏⇩D⇩Gk∈⇩∘I -⇩∘ J. 𝔄 k)⇙ b"
and "f : c ↦⇘(∏⇩D⇩Gj∈⇩∘J. 𝔄 j)⇙ d"
shows "g ∪⇩∘ f : a ∪⇩∘ c ↦⇘∏⇩D⇩Gi∈⇩∘I. 𝔄 i⇙ b ∪⇩∘ d"
by
(
vdiff_of_vunion'
rule: pdg_dg_prod_vunion_is_arr assms: assms(2,3) subset: assms(1)
)
subsection‹Projection›
subsubsection‹Definition and elementary properties›
text‹See Chapter II-3 in \cite{mac_lane_categories_2010}.›
definition dghm_proj :: "V ⇒ (V ⇒ V) ⇒ V ⇒ V" (‹π⇩D⇩G›)
where "π⇩D⇩G I 𝔄 i =
[
(λa∈⇩∘((∏⇩D⇩Gi∈⇩∘I. 𝔄 i)⦇Obj⦈). a⦇i⦈),
(λf∈⇩∘((∏⇩D⇩Gi∈⇩∘I. 𝔄 i)⦇Arr⦈). f⦇i⦈),
(∏⇩D⇩Gi∈⇩∘I. 𝔄 i),
𝔄 i
]⇩∘"
text‹Components.›
lemma dghm_proj_components:
shows "π⇩D⇩G I 𝔄 i⦇ObjMap⦈ = (λa∈⇩∘((∏⇩D⇩Gi∈⇩∘I. 𝔄 i)⦇Obj⦈). a⦇i⦈)"
and "π⇩D⇩G I 𝔄 i⦇ArrMap⦈ = (λf∈⇩∘((∏⇩D⇩Gi∈⇩∘I. 𝔄 i)⦇Arr⦈). f⦇i⦈)"
and "π⇩D⇩G I 𝔄 i⦇HomDom⦈ = (∏⇩D⇩Gi∈⇩∘I. 𝔄 i)"
and "π⇩D⇩G I 𝔄 i⦇HomCod⦈ = 𝔄 i"
unfolding dghm_proj_def dghm_field_simps by (simp_all add: nat_omega_simps)
text‹Object map.›
mk_VLambda dghm_proj_components(1)
|vsv dghm_proj_ObjMap_vsv[dg_cs_intros]|
|vdomain dghm_proj_ObjMap_vdomain[dg_cs_simps]|
|app dghm_proj_ObjMap_app[dg_cs_simps]|
lemma (in pdigraph) dghm_proj_ObjMap_vrange:
assumes "i ∈⇩∘ I"
shows "ℛ⇩∘ (π⇩D⇩G I 𝔄 i⦇ObjMap⦈) ⊆⇩∘ 𝔄 i⦇Obj⦈"
using assms
unfolding dghm_proj_components
by (intro vrange_VLambda_vsubset) (clarsimp simp: dg_prod_components)
text‹Arrow map.›
mk_VLambda dghm_proj_components(2)
|vsv dghm_proj_ArrMap_vsv[dg_cs_intros]|
|vdomain dghm_proj_ArrMap_vdomain[dg_cs_simps]|
|app dghm_proj_ArrMap_app[dg_cs_simps]|
lemma (in pdigraph) dghm_proj_ArrMap_vrange:
assumes "i ∈⇩∘ I"
shows "ℛ⇩∘ (π⇩D⇩G I 𝔄 i⦇ArrMap⦈) ⊆⇩∘ 𝔄 i⦇Arr⦈"
using assms
unfolding dghm_proj_components
by (intro vrange_VLambda_vsubset) (clarsimp simp: dg_prod_components)
subsubsection‹A projection digraph homomorphism is a digraph homomorphism›
lemma (in pdigraph) pdg_dghm_proj_is_dghm:
assumes "i ∈⇩∘ I"
shows "π⇩D⇩G I 𝔄 i : (∏⇩D⇩Gi∈⇩∘I. 𝔄 i) ↦↦⇩D⇩G⇘α⇙ 𝔄 i"
proof(intro is_dghmI)
show "vfsequence (π⇩D⇩G I 𝔄 i)" unfolding dghm_proj_def by auto
show "vcard (π⇩D⇩G I 𝔄 i) = 4⇩ℕ"
unfolding dghm_proj_def by (simp add: nat_omega_simps)
show "π⇩D⇩G I 𝔄 i⦇HomDom⦈ = (∏⇩D⇩Gi∈⇩∘I. 𝔄 i)"
unfolding dghm_proj_components by simp
show "π⇩D⇩G I 𝔄 i⦇HomCod⦈ = 𝔄 i"
unfolding dghm_proj_components by simp
fix f a b assume "f : a ↦⇘∏⇩D⇩Gi∈⇩∘I. 𝔄 i⇙ b"
with assms pdg_digraph_dg_prod show
"π⇩D⇩G I 𝔄 i⦇ArrMap⦈⦇f⦈ : π⇩D⇩G I 𝔄 i⦇ObjMap⦈⦇a⦈ ↦⇘𝔄 i⇙ π⇩D⇩G I 𝔄 i⦇ObjMap⦈⦇b⦈"
by (cs_concl cs_simp: dg_cs_simps cs_intro: dg_cs_intros dg_prod_is_arrD(7))
qed
(
auto simp:
dg_cs_simps dg_cs_intros dg_prod_cs_intros
assms pdg_digraph_dg_prod dghm_proj_ObjMap_vrange
)
lemma (in pdigraph) pdg_dghm_proj_is_dghm':
assumes "i ∈⇩∘ I" and "ℭ = (∏⇩D⇩Gi∈⇩∘I. 𝔄 i)" and "𝔇 = 𝔄 i"
shows "π⇩D⇩G I 𝔄 i : ℭ ↦↦⇩D⇩G⇘α⇙ 𝔇"
using assms(1) unfolding assms(2,3) by (rule pdg_dghm_proj_is_dghm)
lemmas [dg_cs_intros] = pdigraph.pdg_dghm_proj_is_dghm'
subsection‹Digraph product universal property digraph homomorphism›
subsubsection‹Definition and elementary properties›
text‹
The following digraph homomorphism is used in the
proof of the universal property of the product digraph
later in this work.
›
definition dghm_up :: "V ⇒ (V ⇒ V) ⇒ V ⇒ (V ⇒ V) ⇒ V"
where "dghm_up I 𝔄 ℭ φ =
[
(λa∈⇩∘ℭ⦇Obj⦈. (λi∈⇩∘I. φ i⦇ObjMap⦈⦇a⦈)),
(λf∈⇩∘ℭ⦇Arr⦈. (λi∈⇩∘I. φ i⦇ArrMap⦈⦇f⦈)),
ℭ,
(∏⇩D⇩Gi∈⇩∘I. 𝔄 i)
]⇩∘"
text‹Components.›
lemma dghm_up_components:
shows "dghm_up I 𝔄 ℭ φ⦇ObjMap⦈ = (λa∈⇩∘ℭ⦇Obj⦈. (λi∈⇩∘I. φ i⦇ObjMap⦈⦇a⦈))"
and "dghm_up I 𝔄 ℭ φ⦇ArrMap⦈ = (λf∈⇩∘ℭ⦇Arr⦈. (λi∈⇩∘I. φ i⦇ArrMap⦈⦇f⦈))"
and "dghm_up I 𝔄 ℭ φ⦇HomDom⦈ = ℭ"
and "dghm_up I 𝔄 ℭ φ⦇HomCod⦈ = (∏⇩D⇩Gi∈⇩∘I. 𝔄 i)"
unfolding dghm_up_def dghm_field_simps by (simp_all add: nat_omega_simps)
subsubsection‹Object map›
mk_VLambda dghm_up_components(1)
|vsv dghm_up_ObjMap_vsv[dg_cs_intros]|
|vdomain dghm_up_ObjMap_vdomain[dg_cs_simps]|
|app dghm_up_ObjMap_app|
lemma dghm_up_ObjMap_vrange:
assumes "⋀i. i ∈⇩∘ I ⟹ φ i : ℭ ↦↦⇩D⇩G⇘α⇙ 𝔄 i"
shows "ℛ⇩∘ (dghm_up I 𝔄 ℭ φ⦇ObjMap⦈) ⊆⇩∘ (∏⇩D⇩Gi∈⇩∘I. 𝔄 i)⦇Obj⦈"
unfolding dghm_up_components dg_prod_components
proof(intro vrange_VLambda_vsubset vproductI)
fix a assume prems: "a ∈⇩∘ ℭ⦇Obj⦈"
show "∀i∈⇩∘I. (λi∈⇩∘I. φ i⦇ObjMap⦈⦇a⦈)⦇i⦈ ∈⇩∘ 𝔄 i⦇Obj⦈"
proof(intro ballI)
fix i assume prems': "i ∈⇩∘ I"
interpret φ: is_dghm α ℭ ‹𝔄 i› ‹φ i› by (rule assms[OF prems'])
from prems prems' show "(λi∈⇩∘I. φ i⦇ObjMap⦈⦇a⦈)⦇i⦈ ∈⇩∘ 𝔄 i⦇Obj⦈"
by (simp add: φ.dghm_ObjMap_app_in_HomCod_Obj)
qed
qed auto
lemma dghm_up_ObjMap_app_vdomain[dg_cs_simps]:
assumes "a ∈⇩∘ ℭ⦇Obj⦈"
shows "𝒟⇩∘ (dghm_up I 𝔄 ℭ φ⦇ObjMap⦈⦇a⦈) = I"
unfolding dghm_up_ObjMap_app[OF assms] by simp
lemma dghm_up_ObjMap_app_component[dg_cs_simps]:
assumes "a ∈⇩∘ ℭ⦇Obj⦈" and "i ∈⇩∘ I"
shows "dghm_up I 𝔄 ℭ φ⦇ObjMap⦈⦇a⦈⦇i⦈ = φ i⦇ObjMap⦈⦇a⦈"
using assms unfolding dghm_up_components by simp
lemma dghm_up_ObjMap_app_vrange:
assumes "a ∈⇩∘ ℭ⦇Obj⦈" and "⋀i. i ∈⇩∘ I ⟹ φ i : ℭ ↦↦⇩D⇩G⇘α⇙ 𝔄 i"
shows "ℛ⇩∘ (dghm_up I 𝔄 ℭ φ⦇ObjMap⦈⦇a⦈) ⊆⇩∘ (⋃⇩∘i∈⇩∘I. 𝔄 i⦇Obj⦈)"
proof(intro vsubsetI)
fix b assume prems: "b ∈⇩∘ ℛ⇩∘ (dghm_up I 𝔄 ℭ φ⦇ObjMap⦈⦇a⦈)"
have "vsv (dghm_up I 𝔄 ℭ φ⦇ObjMap⦈⦇a⦈)"
unfolding dghm_up_ObjMap_app[OF assms(1)] by auto
with prems obtain i where b_def: "b = dghm_up I 𝔄 ℭ φ⦇ObjMap⦈⦇a⦈⦇i⦈"
and i: "i ∈⇩∘ I"
by (auto elim: vsv.vrange_atE simp: dghm_up_ObjMap_app[OF assms(1)])
interpret φi: is_dghm α ℭ ‹𝔄 i› ‹φ i› by (rule assms(2)[OF i])
from dghm_up_ObjMap_app_component[OF assms(1) i] b_def have b_def':
"b = φ i⦇ObjMap⦈⦇a⦈"
by simp
from assms(1) have "b ∈⇩∘ 𝔄 i⦇Obj⦈"
unfolding b_def' by (auto intro: dg_cs_intros)
with i show "b ∈⇩∘ (⋃⇩∘i∈⇩∘I. 𝔄 i⦇Obj⦈)" by force
qed
subsubsection‹Arrow map›
mk_VLambda dghm_up_components(2)
|vsv dghm_up_ArrMap_vsv[dg_cs_intros]|
|vdomain dghm_up_ArrMap_vdomain[dg_cs_simps]|
|app dghm_up_ArrMap_app|
lemma (in pdigraph) dghm_up_ArrMap_vrange:
assumes "⋀i. i ∈⇩∘ I ⟹ φ i : ℭ ↦↦⇩D⇩G⇘α⇙ 𝔄 i"
shows "ℛ⇩∘ (dghm_up I 𝔄 ℭ φ⦇ArrMap⦈) ⊆⇩∘ (∏⇩D⇩Gi∈⇩∘I. 𝔄 i)⦇Arr⦈"
unfolding dghm_up_components dg_prod_components
proof(intro vrange_VLambda_vsubset vproductI)
fix a assume prems: "a ∈⇩∘ ℭ⦇Arr⦈"
show "∀i∈⇩∘I. (λi∈⇩∘I. φ i⦇ArrMap⦈⦇a⦈)⦇i⦈ ∈⇩∘ 𝔄 i⦇Arr⦈"
proof(intro ballI)
fix i assume prems': "i ∈⇩∘ I"
interpret φ: is_dghm α ℭ ‹𝔄 i› ‹φ i› by (rule assms[OF prems'])
from prems prems' show "(λi∈⇩∘I. φ i⦇ArrMap⦈⦇a⦈)⦇i⦈ ∈⇩∘ 𝔄 i⦇Arr⦈"
by (auto intro: dg_cs_intros)
qed
qed auto
lemma dghm_up_ArrMap_vrange:
assumes "⋀i. i ∈⇩∘ I ⟹ φ i : ℭ ↦↦⇩D⇩G⇘α⇙ 𝔄 i"
shows "ℛ⇩∘ (dghm_up I 𝔄 ℭ φ⦇ArrMap⦈) ⊆⇩∘ (∏⇩D⇩Gi∈⇩∘I. 𝔄 i)⦇Arr⦈"
proof(intro vsubsetI)
fix A assume "A ∈⇩∘ ℛ⇩∘ (dghm_up I 𝔄 ℭ φ⦇ArrMap⦈)"
then obtain a where A_def: "A = dghm_up I 𝔄 ℭ φ⦇ArrMap⦈⦇a⦈"
and a: "a ∈⇩∘ ℭ⦇Arr⦈"
unfolding dghm_up_ArrMap_vdomain dghm_up_components by auto
have "(λi∈⇩∘I. φ i⦇ArrMap⦈⦇a⦈) ∈⇩∘ (∏⇩∘i∈⇩∘I. 𝔄 i⦇Arr⦈)"
proof(intro vproductI)
show "∀i∈⇩∘I. (λi∈⇩∘I. φ i⦇ArrMap⦈⦇a⦈)⦇i⦈ ∈⇩∘ 𝔄 i⦇Arr⦈"
proof(intro ballI)
fix i assume prems: "i ∈⇩∘ I"
interpret φ: is_dghm α ℭ ‹𝔄 i› ‹φ i› by (rule assms[OF prems])
from prems a show "(λi∈⇩∘I. φ i⦇ArrMap⦈⦇a⦈)⦇i⦈ ∈⇩∘ 𝔄 i⦇Arr⦈"
by (auto intro: dg_cs_intros)
qed
qed simp_all
with a show "A ∈⇩∘ (∏⇩D⇩Gi∈⇩∘I. 𝔄 i)⦇Arr⦈"
unfolding A_def dg_prod_components dghm_up_components by simp
qed
lemma dghm_up_ArrMap_app_vdomain[dg_cs_simps]:
assumes "a ∈⇩∘ ℭ⦇Arr⦈"
shows "𝒟⇩∘ (dghm_up I 𝔄 ℭ φ⦇ArrMap⦈⦇a⦈) = I"
unfolding dghm_up_ArrMap_app[OF assms] by simp
lemma dghm_up_ArrMap_app_component[dg_cs_simps]:
assumes "a ∈⇩∘ ℭ⦇Arr⦈" and "i ∈⇩∘ I"
shows "dghm_up I 𝔄 ℭ φ⦇ArrMap⦈⦇a⦈⦇i⦈ = φ i⦇ArrMap⦈⦇a⦈"
using assms unfolding dghm_up_components by simp
lemma dghm_up_ArrMap_app_vrange:
assumes "a ∈⇩∘ ℭ⦇Arr⦈" and "⋀i. i ∈⇩∘ I ⟹ φ i : ℭ ↦↦⇩D⇩G⇘α⇙ 𝔄 i"
shows "ℛ⇩∘ (dghm_up I 𝔄 ℭ φ⦇ArrMap⦈⦇a⦈) ⊆⇩∘ (⋃⇩∘i∈⇩∘I. 𝔄 i⦇Arr⦈)"
proof(intro vsubsetI)
fix b assume prems: "b ∈⇩∘ ℛ⇩∘ (dghm_up I 𝔄 ℭ φ⦇ArrMap⦈⦇a⦈)"
have "vsv (dghm_up I 𝔄 ℭ φ⦇ArrMap⦈⦇a⦈)"
unfolding dghm_up_ArrMap_app[OF assms(1)] by auto
with prems obtain i where b_def: "b = dghm_up I 𝔄 ℭ φ⦇ArrMap⦈⦇a⦈⦇i⦈"
and i: "i ∈⇩∘ I"
by (auto elim: vsv.vrange_atE simp: dghm_up_ArrMap_app[OF assms(1)])
interpret φi: is_dghm α ℭ ‹𝔄 i› ‹φ i› by (rule assms(2)[OF i])
from dghm_up_ArrMap_app_component[OF assms(1) i] b_def have b_def':
"b = φ i⦇ArrMap⦈⦇a⦈"
by simp
from assms(1) have "b ∈⇩∘ 𝔄 i⦇Arr⦈"
unfolding b_def' by (auto intro: dg_cs_intros)
with i show "b ∈⇩∘ (⋃⇩∘i∈⇩∘I. 𝔄 i⦇Arr⦈)" by force
qed
subsubsection‹
Digraph product universal property
digraph homomorphism is a digraph homomorphism
›
lemma (in pdigraph) pdg_dghm_up_is_dghm:
assumes "digraph α ℭ" and "⋀i. i ∈⇩∘ I ⟹ φ i : ℭ ↦↦⇩D⇩G⇘α⇙ 𝔄 i"
shows "dghm_up I 𝔄 ℭ φ : ℭ ↦↦⇩D⇩G⇘α⇙ (∏⇩D⇩Gi∈⇩∘I. 𝔄 i)"
proof-
interpret ℭ: digraph α ℭ by (rule assms(1))
show ?thesis
proof(intro is_dghmI, unfold dghm_up_components(3,4))
show "vfsequence (dghm_up I 𝔄 ℭ φ)" unfolding dghm_up_def by simp
show "vcard (dghm_up I 𝔄 ℭ φ) = 4⇩ℕ"
unfolding dghm_up_def by (simp add: nat_omega_simps)
from assms(2) show "ℛ⇩∘ (dghm_up I 𝔄 ℭ φ⦇ObjMap⦈) ⊆⇩∘ (∏⇩D⇩Gi∈⇩∘I. 𝔄 i)⦇Obj⦈"
by (intro dghm_up_ObjMap_vrange) blast
fix f a b assume prems: "f : a ↦⇘ℭ⇙ b"
then have f: "f ∈⇩∘ ℭ⦇Arr⦈" and a: "a ∈⇩∘ ℭ⦇Obj⦈" and b: "b ∈⇩∘ ℭ⦇Obj⦈" by auto
show "dghm_up I 𝔄 ℭ φ⦇ArrMap⦈⦇f⦈ :
dghm_up I 𝔄 ℭ φ⦇ObjMap⦈⦇a⦈ ↦⇘∏⇩D⇩Gi∈⇩∘I. 𝔄 i⇙ dghm_up I 𝔄 ℭ φ⦇ObjMap⦈⦇b⦈"
proof(rule dg_prod_is_arrI)
fix i assume prems': "i ∈⇩∘ I"
interpret φ: is_dghm α ℭ ‹𝔄 i› ‹φ i› by (rule assms(2)[OF prems'])
from φ.is_dghm_axioms ℭ.digraph_axioms prems pdigraph_axioms prems prems'
show "dghm_up I 𝔄 ℭ φ⦇ArrMap⦈⦇f⦈⦇i⦈ :
dghm_up I 𝔄 ℭ φ⦇ObjMap⦈⦇a⦈⦇i⦈ ↦⇘𝔄 i⇙ dghm_up I 𝔄 ℭ φ⦇ObjMap⦈⦇b⦈⦇i⦈"
by (cs_concl cs_simp: dg_cs_simps cs_intro: dg_cs_intros)
qed (simp_all add: f a b dghm_up_ArrMap_app dghm_up_ObjMap_app)
qed (auto simp: dghm_up_components pdg_digraph_dg_prod dg_cs_intros)
qed
subsubsection‹Further properties›
lemma (in pdigraph) pdg_dghm_comp_dghm_proj_dghm_up:
assumes "digraph α ℭ"
and "⋀i. i ∈⇩∘ I ⟹ φ i : ℭ ↦↦⇩D⇩G⇘α⇙ 𝔄 i"
and "i ∈⇩∘ I"
shows "φ i = π⇩D⇩G I 𝔄 i ∘⇩D⇩G⇩H⇩M dghm_up I 𝔄 ℭ φ"
proof(rule dghm_eqI[of α ℭ ‹𝔄 i› _ ℭ ‹𝔄 i›])
interpret φ: is_dghm α ℭ ‹𝔄 i› ‹φ i› by (rule assms(2)[OF assms(3)])
show "φ i : ℭ ↦↦⇩D⇩G⇘α⇙ 𝔄 i" by (auto intro: dg_cs_intros)
from assms(1,2) have dghm_up: "dghm_up I 𝔄 ℭ φ : ℭ ↦↦⇩D⇩G⇘α⇙ (∏⇩D⇩Gi∈⇩∘I. 𝔄 i)"
by (simp add: pdg_dghm_up_is_dghm)
note dghm_proj = pdg_dghm_proj_is_dghm[OF assms(3)]
from assms(3) pdg_dghm_proj_is_dghm show
"π⇩D⇩G I 𝔄 i ∘⇩D⇩G⇩H⇩M dghm_up I 𝔄 ℭ φ : ℭ ↦↦⇩D⇩G⇘α⇙ 𝔄 i"
by (intro dghm_comp_is_dghm[of α ‹(∏⇩D⇩Gi∈⇩∘I. 𝔄 i)›])
(auto simp: assms dghm_up)
show "φ i⦇ObjMap⦈ = (π⇩D⇩G I 𝔄 i ∘⇩D⇩G⇩H⇩M dghm_up I 𝔄 ℭ φ)⦇ObjMap⦈"
proof(rule vsv_eqI)
show "vsv ((π⇩D⇩G I 𝔄 i ∘⇩D⇩G⇩H⇩M dghm_up I 𝔄 ℭ φ)⦇ObjMap⦈)"
unfolding dghm_comp_components dghm_proj_components dghm_up_components
by (rule vsv_vcomp) simp_all
from
dghm_up_ObjMap_vrange[
OF assms(2), simplified, unfolded dg_prod_components
]
have rd: "ℛ⇩∘ (dghm_up I 𝔄 ℭ φ⦇ObjMap⦈) ⊆⇩∘ 𝒟⇩∘ (π⇩D⇩G I 𝔄 i⦇ObjMap⦈)"
by (simp add: dg_prod_components dg_cs_simps)
show "𝒟⇩∘ (φ i⦇ObjMap⦈) = 𝒟⇩∘ ((π⇩D⇩G I 𝔄 i ∘⇩D⇩G⇩H⇩M dghm_up I 𝔄 ℭ φ)⦇ObjMap⦈)"
unfolding dghm_comp_components vdomain_vcomp_vsubset[OF rd]
by (simp add: dg_cs_simps)
fix a assume "a ∈⇩∘ 𝒟⇩∘ (φ i⦇ObjMap⦈)"
then have a: "a ∈⇩∘ ℭ⦇Obj⦈" by (simp add: dg_cs_simps)
with dghm_up dghm_proj assms(3) show
"φ i⦇ObjMap⦈⦇a⦈ = (π⇩D⇩G I 𝔄 i ∘⇩D⇩G⇩H⇩M dghm_up I 𝔄 ℭ φ)⦇ObjMap⦈⦇a⦈"
by (cs_concl cs_simp: dg_cs_simps cs_intro: dg_cs_intros)
qed auto
show "φ i⦇ArrMap⦈ = (π⇩D⇩G I 𝔄 i ∘⇩D⇩G⇩H⇩M dghm_up I 𝔄 ℭ φ)⦇ArrMap⦈"
proof(rule vsv_eqI)
show "vsv ((π⇩D⇩G I 𝔄 i ∘⇩D⇩G⇩H⇩M dghm_up I 𝔄 ℭ φ)⦇ArrMap⦈)"
unfolding dghm_comp_components dghm_proj_components dghm_up_components
by (rule vsv_vcomp) simp_all
from
dghm_up_ArrMap_vrange[
OF assms(2), simplified, unfolded dg_prod_components
]
have rd: "ℛ⇩∘ (dghm_up I 𝔄 ℭ φ⦇ArrMap⦈) ⊆⇩∘ 𝒟⇩∘ (π⇩D⇩G I 𝔄 i⦇ArrMap⦈)"
by (simp add: dg_prod_components dg_cs_simps)
show "𝒟⇩∘ (φ i⦇ArrMap⦈) = 𝒟⇩∘ ((π⇩D⇩G I 𝔄 i ∘⇩D⇩G⇩H⇩M dghm_up I 𝔄 ℭ φ)⦇ArrMap⦈)"
unfolding dghm_comp_components vdomain_vcomp_vsubset[OF rd]
by (simp add: dg_cs_simps)
fix a assume "a ∈⇩∘ 𝒟⇩∘ (φ i⦇ArrMap⦈)"
then have a: "a ∈⇩∘ ℭ⦇Arr⦈" by (simp add: dg_cs_simps)
with dghm_up dghm_proj assms(3) show
"φ i⦇ArrMap⦈⦇a⦈ = (π⇩D⇩G I 𝔄 i ∘⇩D⇩G⇩H⇩M dghm_up I 𝔄 ℭ φ)⦇ArrMap⦈⦇a⦈"
by (cs_concl cs_simp: dg_cs_simps cs_intro: dg_cs_intros)
qed auto
qed simp_all
lemma (in pdigraph) pdg_dghm_up_eq_dghm_proj:
assumes "𝔉 : ℭ ↦↦⇩D⇩G⇘α⇙ (∏⇩D⇩Gi∈⇩∘I. 𝔄 i)"
and "⋀i. i ∈⇩∘ I ⟹ φ i = π⇩D⇩G I 𝔄 i ∘⇩D⇩G⇩H⇩M 𝔉"
shows "dghm_up I 𝔄 ℭ φ = 𝔉"
proof(rule dghm_eqI)
interpret 𝔉: is_dghm α ℭ ‹(∏⇩D⇩Gi∈⇩∘I. 𝔄 i)› 𝔉 by (rule assms(1))
show "dghm_up I 𝔄 ℭ φ : ℭ ↦↦⇩D⇩G⇘α⇙ (∏⇩D⇩Gi∈⇩∘I. 𝔄 i)"
proof(rule pdg_dghm_up_is_dghm)
fix i assume prems: "i ∈⇩∘ I"
interpret π: is_dghm α ‹(∏⇩D⇩Gi∈⇩∘I. 𝔄 i)› ‹𝔄 i› ‹π⇩D⇩G I 𝔄 i›
using prems by (rule pdg_dghm_proj_is_dghm)
show "φ i : ℭ ↦↦⇩D⇩G⇘α⇙ 𝔄 i"
unfolding assms(2)[OF prems] by (auto intro: dg_cs_intros)
qed (auto intro: dg_cs_intros)
show "dghm_up I 𝔄 ℭ φ⦇ObjMap⦈ = 𝔉⦇ObjMap⦈"
proof(rule vsv_eqI, unfold dghm_up_ObjMap_vdomain)
fix a assume prems: "a ∈⇩∘ ℭ⦇Obj⦈"
show "dghm_up I 𝔄 ℭ φ⦇ObjMap⦈⦇a⦈ = 𝔉⦇ObjMap⦈⦇a⦈"
proof(rule vsv_eqI, unfold dghm_up_ObjMap_app_vdomain[OF prems])
fix i assume prems': "i ∈⇩∘ I"
with pdg_dghm_proj_is_dghm[OF prems'] 𝔉.is_dghm_axioms prems show
"dghm_up I 𝔄 ℭ φ⦇ObjMap⦈⦇a⦈⦇i⦈ = 𝔉⦇ObjMap⦈⦇a⦈⦇i⦈"
by (cs_concl cs_simp: dg_cs_simps assms(2) cs_intro: dg_cs_intros)
qed
(
use 𝔉.dghm_ObjMap_app_in_HomCod_Obj prems in
‹auto simp: dg_prod_components dghm_up_ObjMap_app›
)
qed (auto simp: dghm_up_components dg_cs_simps)
show "dghm_up I 𝔄 ℭ φ⦇ArrMap⦈ = 𝔉⦇ArrMap⦈"
proof(rule vsv_eqI, unfold dghm_up_ArrMap_vdomain)
fix a assume prems: "a ∈⇩∘ ℭ⦇Arr⦈"
show "dghm_up I 𝔄 ℭ φ⦇ArrMap⦈⦇a⦈ = 𝔉⦇ArrMap⦈⦇a⦈"
proof(rule vsv_eqI, unfold dghm_up_ArrMap_app_vdomain[OF prems])
fix i assume prems': "i ∈⇩∘ I"
with pdg_dghm_proj_is_dghm[OF prems'] 𝔉.is_dghm_axioms prems show
"dghm_up I 𝔄 ℭ φ⦇ArrMap⦈⦇a⦈⦇i⦈ = 𝔉⦇ArrMap⦈⦇a⦈⦇i⦈"
by (cs_concl cs_simp: dg_cs_simps assms(2) cs_intro: dg_cs_intros)
qed
(
use 𝔉.dghm_ArrMap_app_in_HomCod_Arr prems in
‹auto simp: dg_prod_components dghm_up_ArrMap_app›
)+
qed (auto simp: dghm_up_components dg_cs_simps)
qed (simp_all add: assms(1))
subsection‹Singleton digraph›
subsubsection‹Object›
lemma dg_singleton_ObjI:
assumes "A = set {⟨j, a⟩}" and "a ∈⇩∘ ℭ⦇Obj⦈"
shows "A ∈⇩∘ (∏⇩D⇩Gi∈⇩∘set {j}. ℭ)⦇Obj⦈"
using assms unfolding dg_prod_components by auto
lemma dg_singleton_ObjE:
assumes "A ∈⇩∘ (∏⇩D⇩Gi∈⇩∘set {j}. ℭ)⦇Obj⦈"
obtains a where "A = set {⟨j, a⟩}" and "a ∈⇩∘ ℭ⦇Obj⦈"
proof-
from vproductD[OF assms[unfolded dg_prod_components], rule_format]
have "vsv A" and [simp]: "𝒟⇩∘ A = set {j}" and Aj: "A⦇j⦈ ∈⇩∘ ℭ⦇Obj⦈"
by simp_all
then interpret A: vsv A by simp
from A.vsv_is_VLambda have "A = set {⟨j, A⦇j⦈⟩}"
by (auto simp: VLambda_vsingleton)
with Aj show ?thesis using that by simp
qed
subsubsection‹Arrow›
lemma dg_singleton_ArrI:
assumes "F = set {⟨j, a⟩}" and "a ∈⇩∘ ℭ⦇Arr⦈"
shows "F ∈⇩∘ (∏⇩D⇩Gj∈⇩∘set {j}. ℭ)⦇Arr⦈"
using assms unfolding dg_prod_components by auto
lemma dg_singleton_ArrE:
assumes "F ∈⇩∘ (∏⇩D⇩Gj∈⇩∘set {j}. ℭ)⦇Arr⦈"
obtains a where "F = set {⟨j, a⟩}" and "a ∈⇩∘ ℭ⦇Arr⦈"
proof-
from vproductD[OF assms[unfolded dg_prod_components], rule_format]
have "vsv F" and [simp]: "𝒟⇩∘ F = set {j}" and Fj: "F⦇j⦈ ∈⇩∘ ℭ⦇Arr⦈"
by simp_all
then interpret F: vsv F by simp
from F.vsv_is_VLambda have "F = set {⟨j, F⦇j⦈⟩}"
by (auto simp: VLambda_vsingleton)
with Fj show ?thesis using that by simp
qed
subsubsection‹Singleton digraph is a digraph›
lemma (in digraph) dg_finite_pdigraph_dg_singleton:
assumes "j ∈⇩∘ Vset α"
shows "finite_pdigraph α (set {j}) (λi. ℭ)"
by (intro finite_pdigraphI pdigraph_baseI)
(auto simp: digraph_axioms Limit_vsingleton_in_VsetI assms)
lemma (in digraph) dg_digraph_dg_singleton:
assumes "j ∈⇩∘ Vset α"
shows "digraph α (∏⇩D⇩Gj∈⇩∘set {j}. ℭ)"
proof-
interpret finite_pdigraph α ‹set {j}› ‹λi. ℭ›
using assms by (rule dg_finite_pdigraph_dg_singleton)
show ?thesis by (rule pdg_digraph_dg_prod)
qed
subsubsection‹Arrow with a domain and a codomain›
lemma (in digraph) dg_singleton_is_arrI:
assumes "j ∈⇩∘ Vset α" and "f : a ↦⇘ℭ⇙ b"
shows "set {⟨j, f⟩} : set {⟨j, a⟩} ↦⇘(∏⇩D⇩Gj∈⇩∘set {j}. ℭ)⇙ set {⟨j, b⟩}"
proof-
interpret finite_pdigraph α ‹set {j}› ‹λi. ℭ›
by (rule dg_finite_pdigraph_dg_singleton[OF assms(1)])
from assms(2) show ?thesis by (intro dg_prod_is_arrI) auto
qed
lemma (in digraph) dg_singleton_is_arrD:
assumes "set {⟨j, f⟩} : set {⟨j, a⟩} ↦⇘(∏⇩D⇩Gj∈⇩∘set {j}. ℭ)⇙ set {⟨j, b⟩}"
and "j ∈⇩∘ Vset α"
shows "f : a ↦⇘ℭ⇙ b"
proof-
interpret finite_pdigraph α ‹set {j}› ‹λi. ℭ›
by (rule dg_finite_pdigraph_dg_singleton[OF assms(2)])
from dg_prod_is_arrD(7)[OF assms(1)] show ?thesis by simp
qed
lemma (in digraph) dg_singleton_is_arrE:
assumes "set {⟨j, f⟩} : set {⟨j, a⟩} ↦⇘(∏⇩D⇩Gj∈⇩∘set {j}. ℭ)⇙ set {⟨j, b⟩}"
and "j ∈⇩∘ Vset α"
obtains "f : a ↦⇘ℭ⇙ b"
using assms dg_singleton_is_arrD by auto
subsection‹Singleton digraph homomorphism›
definition dghm_singleton :: "V ⇒ V ⇒ V"
where "dghm_singleton j ℭ =
[
(λa∈⇩∘ℭ⦇Obj⦈. set {⟨j, a⟩}),
(λf∈⇩∘ℭ⦇Arr⦈. set {⟨j, f⟩}),
ℭ,
(∏⇩D⇩Gj∈⇩∘set {j}. ℭ)
]⇩∘"
text‹Components.›
lemma dghm_singleton_components:
shows "dghm_singleton j ℭ⦇ObjMap⦈ = (λa∈⇩∘ℭ⦇Obj⦈. set {⟨j, a⟩})"
and "dghm_singleton j ℭ⦇ArrMap⦈ = (λf∈⇩∘ℭ⦇Arr⦈. set {⟨j, f⟩})"
and "dghm_singleton j ℭ⦇HomDom⦈ = ℭ"
and "dghm_singleton j ℭ⦇HomCod⦈ = (∏⇩D⇩Gj∈⇩∘set {j}. ℭ)"
unfolding dghm_singleton_def dghm_field_simps
by (simp_all add: nat_omega_simps)
subsubsection‹Object map›
mk_VLambda dghm_singleton_components(1)
|vsv dghm_singleton_ObjMap_vsv[dg_cs_intros]|
|vdomain dghm_singleton_ObjMap_vdomain[dg_cs_simps]|
|app dghm_singleton_ObjMap_app[dg_prod_cs_simps]|
lemma dghm_singleton_ObjMap_vrange[dg_cs_simps]:
"ℛ⇩∘ (dghm_singleton j ℭ⦇ObjMap⦈) = (∏⇩D⇩Gj∈⇩∘set {j}. ℭ)⦇Obj⦈"
proof(intro vsubset_antisym vsubsetI)
fix A assume "A ∈⇩∘ ℛ⇩∘ (dghm_singleton j ℭ⦇ObjMap⦈)"
then obtain a where A_def: "A = set {⟨j, a⟩}" and a: "a ∈⇩∘ ℭ⦇Obj⦈"
unfolding dghm_singleton_components by auto
then show "A ∈⇩∘ (∏⇩D⇩Gj∈⇩∘set {j}. ℭ)⦇Obj⦈"
unfolding dg_prod_components by auto
next
fix A assume "A ∈⇩∘ (∏⇩D⇩Gj∈⇩∘set {j}. ℭ)⦇Obj⦈"
from vproductD[OF this[unfolded dg_prod_components], rule_format]
have "vsv A"
and [simp]: "𝒟⇩∘ A = set {j}"
and Ai: "⋀i. i ∈⇩∘ set {j} ⟹ A⦇i⦈ ∈⇩∘ ℭ⦇Obj⦈"
by auto
then interpret A: vsv A by simp
from Ai have "A⦇j⦈ ∈⇩∘ ℭ⦇Obj⦈" using Ai by auto
moreover with A.vsv_is_VLambda have "A = (λf∈⇩∘ℭ⦇Obj⦈. set {⟨j, f⟩})⦇A⦇j⦈⦈"
by (simp add: VLambda_vsingleton)
ultimately show "A ∈⇩∘ ℛ⇩∘ (dghm_singleton j ℭ⦇ObjMap⦈)"
unfolding dghm_singleton_components
by
(
metis
dghm_singleton_ObjMap_vdomain
dghm_singleton_ObjMap_vsv
dghm_singleton_components(1)
vsv.vsv_vimageI2
)
qed
subsubsection‹Arrow map›
mk_VLambda dghm_singleton_components(2)
|vsv dghm_singleton_ArrMap_vsv[dg_cs_intros]|
|vdomain dghm_singleton_ArrMap_vdomain[dg_cs_simps]|
|app dghm_singleton_ArrMap_app[dg_prod_cs_simps]|
lemma dghm_singleton_ArrMap_vrange[dg_cs_simps]:
"ℛ⇩∘ (dghm_singleton j ℭ⦇ArrMap⦈) = (∏⇩D⇩Gj∈⇩∘set {j}. ℭ)⦇Arr⦈"
proof(intro vsubset_antisym vsubsetI)
fix F assume "F ∈⇩∘ ℛ⇩∘ (dghm_singleton j ℭ⦇ArrMap⦈)"
then obtain f where "F = set {⟨j, f⟩}" and "f ∈⇩∘ ℭ⦇Arr⦈"
unfolding dghm_singleton_components by auto
then show "F ∈⇩∘ (∏⇩D⇩Gj∈⇩∘set {j}. ℭ)⦇Arr⦈"
unfolding dg_prod_components by auto
next
fix F assume "F ∈⇩∘ (∏⇩D⇩Gj∈⇩∘set {j}. ℭ)⦇Arr⦈"
from vproductD[OF this[unfolded dg_prod_components], rule_format]
have "vsv F"
and [simp]: "𝒟⇩∘ F = set {j}"
and Fi: "⋀i. i ∈⇩∘ set {j} ⟹ F⦇i⦈ ∈⇩∘ ℭ⦇Arr⦈"
by auto
then interpret F: vsv F by simp
from Fi have "F⦇j⦈ ∈⇩∘ ℭ⦇Arr⦈" using Fi by auto
moreover with F.vsv_is_VLambda have "F = (λf∈⇩∘ℭ⦇Arr⦈. set {⟨j, f⟩})⦇F⦇j⦈⦈"
by (simp add: VLambda_vsingleton)
ultimately show "F ∈⇩∘ ℛ⇩∘ (dghm_singleton j ℭ⦇ArrMap⦈)"
unfolding dghm_singleton_components
by
(
metis
dghm_singleton_ArrMap_vdomain
dghm_singleton_ArrMap_vsv
dghm_singleton_components(2)
vsv.vsv_vimageI2
)
qed
subsubsection‹Singleton digraph homomorphism is an isomorphism of digraphs›
lemma (in digraph) dg_dghm_singleton_is_dghm:
assumes "j ∈⇩∘ Vset α"
shows "dghm_singleton j ℭ : ℭ ↦↦⇩D⇩G⇩.⇩i⇩s⇩o⇘α⇙ (∏⇩D⇩Gj∈⇩∘set {j}. ℭ)"
proof-
interpret finite_pdigraph α ‹set {j}› ‹λi. ℭ›
by (rule dg_finite_pdigraph_dg_singleton[OF assms])
show ?thesis
proof(intro is_iso_dghmI is_dghmI)
show "vfsequence (dghm_singleton j ℭ)" unfolding dghm_singleton_def by simp
show "vcard (dghm_singleton j ℭ) = 4⇩ℕ"
unfolding dghm_singleton_def by (simp add: nat_omega_simps)
show "ℛ⇩∘ (dghm_singleton j ℭ⦇ObjMap⦈) ⊆⇩∘ (∏⇩D⇩Gj∈⇩∘set {j}. ℭ)⦇Obj⦈"
by (simp add: dg_cs_simps)
show "dghm_singleton j ℭ⦇ArrMap⦈⦇f⦈ :
dghm_singleton j ℭ⦇ObjMap⦈⦇a⦈ ↦⇘∏⇩D⇩Gj∈⇩∘set {j}. ℭ⇙
dghm_singleton j ℭ⦇ObjMap⦈⦇b⦈"
if "f : a ↦⇘ℭ⇙ b" for f a b
using that
proof(intro dg_prod_is_arrI)
fix k assume "k ∈⇩∘ set {j}"
then have k_def: "k = j" by simp
from that show "dghm_singleton j ℭ⦇ArrMap⦈⦇f⦈⦇k⦈ :
dghm_singleton j ℭ⦇ObjMap⦈⦇a⦈⦇k⦈ ↦⇘ℭ⇙ dghm_singleton j ℭ⦇ObjMap⦈⦇b⦈⦇k⦈"
by
(
cs_concl
cs_simp: k_def V_cs_simps dg_cs_simps dg_prod_cs_simps
cs_intro: dg_cs_intros
)
qed
(
cs_concl
cs_simp: V_cs_simps dg_prod_cs_simps
cs_intro: V_cs_intros dg_cs_intros
)+
show "ℛ⇩∘ (dghm_singleton j ℭ⦇ObjMap⦈) = (∏⇩D⇩Gj∈⇩∘set {j}. ℭ)⦇Obj⦈"
by (simp add: dg_cs_simps)
show "ℛ⇩∘ (dghm_singleton j ℭ⦇ArrMap⦈) = (∏⇩D⇩Gj∈⇩∘set {j}. ℭ)⦇Arr⦈"
by (simp add: dg_cs_simps)
qed
(
auto simp:
dg_cs_intros
dg_digraph_dg_singleton[OF assms]
dghm_singleton_components
)
qed
subsection‹Product of two digraphs›
subsubsection‹Definition and elementary properties›
text‹See Chapter II-3 in \cite{mac_lane_categories_2010}.›
definition dg_prod_2 :: "V ⇒ V ⇒ V" (infixr ‹×⇩D⇩G› 80)
where "𝔄 ×⇩D⇩G 𝔅 ≡ dg_prod (2⇩ℕ) (if2 𝔄 𝔅)"
subsubsection‹Product of two digraphs is a digraph›
context
fixes α 𝔄 𝔅
assumes 𝔄: "digraph α 𝔄" and 𝔅: "digraph α 𝔅"
begin
interpretation 𝒵 α by (rule digraphD[OF 𝔄(1)])
interpretation 𝔄: digraph α 𝔄 by (rule 𝔄)
interpretation 𝔅: digraph α 𝔅 by (rule 𝔅)
lemma finite_pdigraph_dg_prod_2: "finite_pdigraph α (2⇩ℕ) (if2 𝔄 𝔅)"
proof(intro finite_pdigraphI pdigraph_baseI)
from Axiom_of_Infinity show z1_in_Vset: "2⇩ℕ ∈⇩∘ Vset α" by blast
show "digraph α (i = 0 ? 𝔄 : 𝔅)" if "i ∈⇩∘ 2⇩ℕ" for i
by (auto intro: dg_cs_intros)
qed auto
interpretation finite_pdigraph α ‹2⇩ℕ› ‹if2 𝔄 𝔅›
by (intro finite_pdigraph_dg_prod_2 𝔄 𝔅)
lemma digraph_dg_prod_2[dg_cs_intros]: "digraph α (𝔄 ×⇩D⇩G 𝔅)"
proof-
show ?thesis unfolding dg_prod_2_def by (rule pdg_digraph_dg_prod)
qed
end
subsubsection‹Object›
context
fixes α 𝔄 𝔅
assumes 𝔄: "digraph α 𝔄" and 𝔅: "digraph α 𝔅"
begin
lemma dg_prod_2_ObjI:
assumes "a ∈⇩∘ 𝔄⦇Obj⦈" and "b ∈⇩∘ 𝔅⦇Obj⦈"
shows "[a, b]⇩∘ ∈⇩∘ (𝔄 ×⇩D⇩G 𝔅)⦇Obj⦈"
unfolding dg_prod_2_def dg_prod_components
proof(intro vproductI ballI)
show "𝒟⇩∘ [a, b]⇩∘ = 2⇩ℕ" by (simp add: nat_omega_simps two)
fix i assume "i ∈⇩∘ 2⇩ℕ"
then consider ‹i = 0› | ‹i = 1⇩ℕ› unfolding two by auto
then show "[a, b]⇩∘⦇i⦈ ∈⇩∘ (if i = 0 then 𝔄 else 𝔅)⦇Obj⦈"
by cases (simp_all add: nat_omega_simps assms(1,2))
qed auto
lemma dg_prod_2_ObjI'[dg_prod_cs_intros]:
assumes "ab = [a, b]⇩∘" and "a ∈⇩∘ 𝔄⦇Obj⦈" and "b ∈⇩∘ 𝔅⦇Obj⦈"
shows "ab ∈⇩∘ (𝔄 ×⇩D⇩G 𝔅)⦇Obj⦈"
using assms(2,3) unfolding assms(1) by (rule dg_prod_2_ObjI)
lemma dg_prod_2_ObjE:
assumes "ab ∈⇩∘ (𝔄 ×⇩D⇩G 𝔅)⦇Obj⦈"
obtains a b where "ab = [a, b]⇩∘" and "a ∈⇩∘ 𝔄⦇Obj⦈" and "b ∈⇩∘ 𝔅⦇Obj⦈"
proof-
from vproductD[OF assms[unfolded dg_prod_2_def dg_prod_components]]
have vsv_ab: "vsv ab"
and dom_ab: "𝒟⇩∘ ab = 2⇩ℕ"
and ab_app: "⋀i. i ∈⇩∘ 2⇩ℕ ⟹ ab⦇i⦈ ∈⇩∘ (if i = 0 then 𝔄 else 𝔅)⦇Obj⦈"
by auto
have dom_ab[simp]: "𝒟⇩∘ ab = 2⇩ℕ"
unfolding dom_ab by (simp add: nat_omega_simps two)
interpret vsv ab by (rule vsv_ab)
have "ab = [vpfst ab, vpsnd ab]⇩∘"
by (rule vsv_vfsequence_two[symmetric]) auto
moreover from ab_app[of 0] have "vpfst ab ∈⇩∘ 𝔄⦇Obj⦈" by simp
moreover from ab_app[of ‹1⇩ℕ›] have "vpsnd ab ∈⇩∘ 𝔅⦇Obj⦈" by simp
ultimately show ?thesis using that by auto
qed
end
subsubsection‹Arrow›
context
fixes α 𝔄 𝔅
assumes 𝔄: "digraph α 𝔄" and 𝔅: "digraph α 𝔅"
begin
lemma dg_prod_2_ArrI:
assumes "g ∈⇩∘ 𝔄⦇Arr⦈" and "f ∈⇩∘ 𝔅⦇Arr⦈"
shows "[g, f]⇩∘ ∈⇩∘ (𝔄 ×⇩D⇩G 𝔅)⦇Arr⦈"
unfolding dg_prod_2_def dg_prod_components
proof(intro vproductI ballI)
show "𝒟⇩∘ [g, f]⇩∘ = 2⇩ℕ" by (simp add: nat_omega_simps two)
fix i assume "i ∈⇩∘ 2⇩ℕ"
then consider ‹i = 0› | ‹i = 1⇩ℕ› unfolding two by auto
then show "[g, f]⇩∘⦇i⦈ ∈⇩∘ (if i = 0 then 𝔄 else 𝔅)⦇Arr⦈"
by cases (simp_all add: nat_omega_simps assms(1,2))
qed auto
lemma dg_prod_2_ArrI'[dg_prod_cs_intros]:
assumes "gf = [g, f]⇩∘" and "g ∈⇩∘ 𝔄⦇Arr⦈" and "f ∈⇩∘ 𝔅⦇Arr⦈"
shows "[g, f]⇩∘ ∈⇩∘ (𝔄 ×⇩D⇩G 𝔅)⦇Arr⦈"
using assms(2,3) unfolding assms(1) by (rule dg_prod_2_ArrI)
lemma dg_prod_2_ArrE:
assumes "gf ∈⇩∘ (𝔄 ×⇩D⇩G 𝔅)⦇Arr⦈"
obtains g f where "gf = [g, f]⇩∘" and "g ∈⇩∘ 𝔄⦇Arr⦈" and "f ∈⇩∘ 𝔅⦇Arr⦈"
proof-
from vproductD[OF assms[unfolded dg_prod_2_def dg_prod_components]]
have vsv_gf: "vsv gf"
and dom_gf: "𝒟⇩∘ gf = 2⇩ℕ"
and gf_app: "⋀i. i ∈⇩∘ 2⇩ℕ ⟹ gf⦇i⦈ ∈⇩∘ (if i = 0 then 𝔄 else 𝔅)⦇Arr⦈"
by auto
have dom_gf[simp]: "𝒟⇩∘ gf = 2⇩ℕ" unfolding dom_gf by (simp add: two)
interpret vsv gf by (rule vsv_gf)
have "gf = [vpfst gf, vpsnd gf]⇩∘"
by (rule vsv_vfsequence_two[symmetric]) auto
moreover from gf_app[of 0] have "vpfst gf ∈⇩∘ 𝔄⦇Arr⦈" by simp
moreover from gf_app[of ‹1⇩ℕ›] have "vpsnd gf ∈⇩∘ 𝔅⦇Arr⦈" by simp
ultimately show ?thesis using that by auto
qed
end
subsubsection‹Arrow with a domain and a codomain›
context
fixes α 𝔄 𝔅
assumes 𝔄: "digraph α 𝔄" and 𝔅: "digraph α 𝔅"
begin
interpretation 𝒵 α by (rule digraphD[OF 𝔄(1)])
interpretation 𝔄: digraph α 𝔄 by (rule 𝔄)
interpretation 𝔅: digraph α 𝔅 by (rule 𝔅)
interpretation finite_pdigraph α ‹2⇩ℕ› ‹if2 𝔄 𝔅›
by (intro finite_pdigraph_dg_prod_2 𝔄 𝔅)
lemma dg_prod_2_is_arrI:
assumes "g : a ↦⇘𝔄⇙ c" and "f : b ↦⇘𝔅⇙ d"
shows "[g, f]⇩∘ : [a, b]⇩∘ ↦⇘𝔄 ×⇩D⇩G 𝔅⇙ [c, d]⇩∘"
unfolding dg_prod_2_def
proof(rule dg_prod_is_arrI)
show "[g, f]⇩∘⦇i⦈ : [a, b]⇩∘⦇i⦈ ↦⇘if i = 0 then 𝔄 else 𝔅⇙ [c, d]⇩∘⦇i⦈"
if "i ∈⇩∘ 2⇩ℕ" for i
proof-
from that consider ‹i = 0› | ‹i = 1⇩ℕ› unfolding two by auto
then show "[g, f]⇩∘⦇i⦈ : [a, b]⇩∘⦇i⦈ ↦⇘if i = 0 then 𝔄 else 𝔅⇙ [c, d]⇩∘⦇i⦈"
by cases (simp_all add: nat_omega_simps assms)
qed
qed (auto simp: nat_omega_simps two)
lemma dg_prod_2_is_arrI'[dg_prod_cs_intros]:
assumes "gf = [g, f]⇩∘"
and "ab = [a, b]⇩∘"
and "cd = [c, d]⇩∘"
and "g : a ↦⇘𝔄⇙ c"
and "f : b ↦⇘𝔅⇙ d"
shows "gf : ab ↦⇘𝔄 ×⇩D⇩G 𝔅⇙ cd"
using assms(4,5) unfolding assms(1,2,3) by (rule dg_prod_2_is_arrI)
lemma dg_prod_2_is_arrE:
assumes "gf : ab ↦⇘𝔄 ×⇩D⇩G 𝔅⇙ cd"
obtains g f a b c d
where "gf = [g, f]⇩∘"
and "ab = [a, b]⇩∘"
and "cd = [c, d]⇩∘"
and "g : a ↦⇘𝔄⇙ c"
and "f : b ↦⇘𝔅⇙ d"
proof-
from dg_prod_is_arrD[OF assms[unfolded dg_prod_2_def]]
have [simp]: "vsv gf" "𝒟⇩∘ gf = 2⇩ℕ" "vsv ab" "𝒟⇩∘ ab = 2⇩ℕ" "vsv cd" "𝒟⇩∘ cd = 2⇩ℕ"
and gf_app:
"⋀i. i ∈⇩∘ 2⇩ℕ ⟹ gf⦇i⦈ : ab⦇i⦈ ↦⇘if i = 0 then 𝔄 else 𝔅⇙ cd⦇i⦈"
by (auto simp: two)
have "gf = [vpfst gf, vpsnd gf]⇩∘" by (simp add: vsv_vfsequence_two)
moreover have "ab = [vpfst ab, vpsnd ab]⇩∘" by (simp add: vsv_vfsequence_two)
moreover have "cd = [vpfst cd, vpsnd cd]⇩∘" by (simp add: vsv_vfsequence_two)
moreover from gf_app[of 0] have "vpfst gf : vpfst ab ↦⇘𝔄⇙ vpfst cd" by simp
moreover from gf_app[of ‹1⇩ℕ›] have "vpsnd gf : vpsnd ab ↦⇘𝔅⇙ vpsnd cd"
by (simp add: nat_omega_simps)
ultimately show ?thesis using that by auto
qed
end
subsubsection‹Domain›
context
fixes α 𝔄 𝔅
assumes 𝔄: "digraph α 𝔄" and 𝔅: "digraph α 𝔅"
begin
lemma dg_prod_2_Dom_vsv: "vsv ((𝔄 ×⇩D⇩G 𝔅)⦇Dom⦈)"
unfolding dg_prod_2_def dg_prod_components by simp
lemma dg_prod_2_Dom_vdomain[dg_cs_simps]:
"𝒟⇩∘ ((𝔄 ×⇩D⇩G 𝔅)⦇Dom⦈) = (𝔄 ×⇩D⇩G 𝔅)⦇Arr⦈"
unfolding dg_prod_2_def dg_prod_components by simp
lemma dg_prod_2_Dom_app[dg_prod_cs_simps]:
assumes "[g, f]⇩∘ ∈⇩∘ (𝔄 ×⇩D⇩G 𝔅)⦇Arr⦈"
shows "(𝔄 ×⇩D⇩G 𝔅)⦇Dom⦈⦇g, f⦈⇩∙ = [𝔄⦇Dom⦈⦇g⦈, 𝔅⦇Dom⦈⦇f⦈]⇩∘"
proof-
from assms obtain ab cd where gf: "[g, f]⇩∘ : ab ↦⇘𝔄 ×⇩D⇩G 𝔅⇙ cd"
by (auto intro: is_arrI)
then have Dom_gf: "(𝔄 ×⇩D⇩G 𝔅)⦇Dom⦈⦇g, f⦈⇩∙ = ab"
by (simp add: dg_cs_simps)
from gf obtain a b c d
where ab_def: "ab = [a, b]⇩∘"
and "cd = [c, d]⇩∘"
and "g : a ↦⇘𝔄⇙ c"
and "f : b ↦⇘𝔅⇙ d"
by (elim dg_prod_2_is_arrE[OF 𝔄 𝔅]) simp
then have Dom_g: "𝔄⦇Dom⦈⦇g⦈ = a" and Dom_f: "𝔅⦇Dom⦈⦇f⦈ = b"
by (simp_all add: dg_cs_simps)
show ?thesis unfolding Dom_gf ab_def Dom_g Dom_f ..
qed
lemma dg_prod_2_Dom_vrange: "ℛ⇩∘ ((𝔄 ×⇩D⇩G 𝔅)⦇Dom⦈) ⊆⇩∘ (𝔄 ×⇩D⇩G 𝔅)⦇Obj⦈"
proof(rule vsv.vsv_vrange_vsubset, unfold dg_cs_simps)
show "vsv ((𝔄 ×⇩D⇩G 𝔅)⦇Dom⦈)" by (rule dg_prod_2_Dom_vsv)
fix gf assume prems: "gf ∈⇩∘ (𝔄 ×⇩D⇩G 𝔅)⦇Arr⦈"
then obtain g f where gf_def: "gf = [g, f]⇩∘"
and g: "g ∈⇩∘ 𝔄⦇Arr⦈"
and f: "f ∈⇩∘ 𝔅⦇Arr⦈"
by (elim dg_prod_2_ArrE[OF 𝔄 𝔅]) simp
from g f obtain a b c d where g: "g : a ↦⇘𝔄⇙ c" and f: "f : b ↦⇘𝔅⇙ d"
by (auto intro!: is_arrI)
from 𝔄 𝔅 g f show "(𝔄 ×⇩D⇩G 𝔅)⦇Dom⦈⦇gf⦈ ∈⇩∘ (𝔄 ×⇩D⇩G 𝔅)⦇Obj⦈"
unfolding gf_def dg_prod_2_Dom_app[OF prems[unfolded gf_def]]
by (cs_concl cs_simp: dg_cs_simps cs_intro: dg_cs_intros dg_prod_cs_intros)
qed
end
subsubsection‹Codomain›
context
fixes α 𝔄 𝔅
assumes 𝔄: "digraph α 𝔄" and 𝔅: "digraph α 𝔅"
begin
lemma dg_prod_2_Cod_vsv: "vsv ((𝔄 ×⇩D⇩G 𝔅)⦇Cod⦈)"
unfolding dg_prod_2_def dg_prod_components by simp
lemma dg_prod_2_Cod_vdomain[dg_cs_simps]:
"𝒟⇩∘ ((𝔄 ×⇩D⇩G 𝔅)⦇Cod⦈) = (𝔄 ×⇩D⇩G 𝔅)⦇Arr⦈"
unfolding dg_prod_2_def dg_prod_components by simp
lemma dg_prod_2_Cod_app[dg_prod_cs_simps]:
assumes "[g, f]⇩∘ ∈⇩∘ (𝔄 ×⇩D⇩G 𝔅)⦇Arr⦈"
shows "(𝔄 ×⇩D⇩G 𝔅)⦇Cod⦈⦇g, f⦈⇩∙ = [𝔄⦇Cod⦈⦇g⦈, 𝔅⦇Cod⦈⦇f⦈]⇩∘"
proof-
from assms obtain ab cd where gf: "[g, f]⇩∘ : ab ↦⇘𝔄 ×⇩D⇩G 𝔅⇙ cd"
by (auto intro: is_arrI)
then have Cod_gf: "(𝔄 ×⇩D⇩G 𝔅)⦇Cod⦈⦇g, f⦈⇩∙ = cd"
by (simp add: dg_cs_simps)
from gf obtain a b c d
where "ab = [a, b]⇩∘"
and cd_def: "cd = [c, d]⇩∘"
and "g : a ↦⇘𝔄⇙ c"
and "f : b ↦⇘𝔅⇙ d"
by (elim dg_prod_2_is_arrE[OF 𝔄 𝔅]) simp
then have Cod_g: "𝔄⦇Cod⦈⦇g⦈ = c" and Cod_f: "𝔅⦇Cod⦈⦇f⦈ = d"
by (simp_all add: dg_cs_simps)
show ?thesis unfolding Cod_gf cd_def Cod_g Cod_f ..
qed
lemma dg_prod_2_Cod_vrange: "ℛ⇩∘ ((𝔄 ×⇩D⇩G 𝔅)⦇Cod⦈) ⊆⇩∘ (𝔄 ×⇩D⇩G 𝔅)⦇Obj⦈"
proof(rule vsv.vsv_vrange_vsubset, unfold dg_cs_simps)
show "vsv ((𝔄 ×⇩D⇩G 𝔅)⦇Cod⦈)" by (rule dg_prod_2_Cod_vsv)
fix gf assume prems: "gf ∈⇩∘ (𝔄 ×⇩D⇩G 𝔅)⦇Arr⦈"
then obtain g f where gf_def: "gf = [g, f]⇩∘"
and g: "g ∈⇩∘ 𝔄⦇Arr⦈"
and f: "f ∈⇩∘ 𝔅⦇Arr⦈"
by (elim dg_prod_2_ArrE[OF 𝔄 𝔅]) simp
from g f obtain a b c d where g: "g : a ↦⇘𝔄⇙ c" and f: "f : b ↦⇘𝔅⇙ d"
by (auto intro!: is_arrI)
from 𝔄 𝔅 g f show "(𝔄 ×⇩D⇩G 𝔅)⦇Cod⦈⦇gf⦈ ∈⇩∘ (𝔄 ×⇩D⇩G 𝔅)⦇Obj⦈"
unfolding gf_def dg_prod_2_Cod_app[OF prems[unfolded gf_def]]
by (cs_concl cs_simp: dg_cs_simps cs_intro: dg_cs_intros dg_prod_cs_intros)
qed
end
subsubsection‹Opposite product digraph›
context
fixes α 𝔄 𝔅
assumes 𝔄: "digraph α 𝔄" and 𝔅: "digraph α 𝔅"
begin
interpretation 𝔄: digraph α 𝔄 by (rule 𝔄)
interpretation 𝔅: digraph α 𝔅 by (rule 𝔅)
lemma dg_prod_2_op_dg_dg_Obj[dg_op_simps]:
"(op_dg 𝔄 ×⇩D⇩G 𝔅)⦇Obj⦈ = (𝔄 ×⇩D⇩G 𝔅)⦇Obj⦈"
proof
(
intro vsubset_antisym vsubsetI;
elim dg_prod_2_ObjE[OF 𝔄.digraph_op 𝔅] dg_prod_2_ObjE[OF 𝔄 𝔅],
(unfold dg_op_simps)?
)
fix ab a b assume prems: "ab = [a, b]⇩∘" "a ∈⇩∘ 𝔄⦇Obj⦈" "b ∈⇩∘ 𝔅⦇Obj⦈"
from 𝔄 𝔅 prems(2,3) show "ab ∈⇩∘ (𝔄 ×⇩D⇩G 𝔅)⦇Obj⦈"
unfolding prems(1) dg_op_simps
by (cs_concl cs_simp: dg_cs_simps cs_intro: dg_prod_cs_intros)
next
fix ab a b assume prems: "ab = [a, b]⇩∘" "a ∈⇩∘ 𝔄⦇Obj⦈" "b ∈⇩∘ 𝔅⦇Obj⦈"
from 𝔄 𝔅 prems(2,3) show "ab ∈⇩∘ (op_dg 𝔄 ×⇩D⇩G 𝔅)⦇Obj⦈"
unfolding prems(1) dg_op_simps
by (cs_concl cs_simp: dg_cs_simps cs_intro: dg_op_intros dg_prod_cs_intros)
qed
lemma dg_prod_2_dg_op_dg_Obj[dg_op_simps]:
"(𝔄 ×⇩D⇩G op_dg 𝔅)⦇Obj⦈ = (𝔄 ×⇩D⇩G 𝔅)⦇Obj⦈"
proof
(
intro vsubset_antisym vsubsetI;
elim dg_prod_2_ObjE[OF 𝔄 𝔅.digraph_op] dg_prod_2_ObjE[OF 𝔄 𝔅],
(unfold dg_op_simps)?
)
fix ab a b assume prems: "ab = [a, b]⇩∘" "a ∈⇩∘ 𝔄⦇Obj⦈" "b ∈⇩∘ 𝔅⦇Obj⦈"
from 𝔄 𝔅 prems(2,3) show "ab ∈⇩∘ (𝔄 ×⇩D⇩G 𝔅)⦇Obj⦈"
unfolding prems(1) dg_op_simps
by (cs_concl cs_simp: dg_cs_simps cs_intro: dg_prod_cs_intros)
next
fix ab a b assume prems: "ab = [a, b]⇩∘" "a ∈⇩∘ 𝔄⦇Obj⦈" "b ∈⇩∘ 𝔅⦇Obj⦈"
from 𝔄 𝔅 prems(2,3) show "ab ∈⇩∘ (𝔄 ×⇩D⇩G op_dg 𝔅)⦇Obj⦈"
unfolding prems(1) dg_op_simps
by (cs_concl cs_simp: dg_cs_simps cs_intro: dg_prod_cs_intros dg_op_intros)
qed
lemma dg_prod_2_op_dg_dg_Arr[dg_op_simps]:
"(op_dg 𝔄 ×⇩D⇩G 𝔅)⦇Arr⦈ = (𝔄 ×⇩D⇩G 𝔅)⦇Arr⦈"
proof
(
intro vsubset_antisym vsubsetI;
elim dg_prod_2_ArrE[OF 𝔄.digraph_op 𝔅] dg_prod_2_ArrE[OF 𝔄 𝔅],
(unfold dg_op_simps)?
)
fix ab a b assume prems: "ab = [a, b]⇩∘" "a ∈⇩∘ 𝔄⦇Arr⦈" "b ∈⇩∘ 𝔅⦇Arr⦈"
from 𝔄 𝔅 prems(2,3) show "ab ∈⇩∘ (𝔄 ×⇩D⇩G 𝔅)⦇Arr⦈"
unfolding prems(1) dg_op_simps
by (cs_concl cs_simp: dg_cs_simps cs_intro: dg_prod_cs_intros)
next
fix ab a b assume prems: "ab = [a, b]⇩∘" "a ∈⇩∘ 𝔄⦇Arr⦈" "b ∈⇩∘ 𝔅⦇Arr⦈"
from 𝔄 𝔅 prems(2,3) show "ab ∈⇩∘ (op_dg 𝔄 ×⇩D⇩G 𝔅)⦇Arr⦈"
unfolding prems(1) dg_op_simps
by (cs_concl cs_simp: dg_cs_simps cs_intro: dg_prod_cs_intros dg_op_intros)
qed
lemma dg_prod_2_dg_op_dg_Arr[dg_op_simps]:
"(𝔄 ×⇩D⇩G op_dg 𝔅)⦇Arr⦈ = (𝔄 ×⇩D⇩G 𝔅)⦇Arr⦈"
proof
(
intro vsubset_antisym vsubsetI;
elim dg_prod_2_ArrE[OF 𝔄 𝔅.digraph_op] dg_prod_2_ArrE[OF 𝔄 𝔅],
(unfold dg_op_simps)?
)
fix ab a b assume prems: "ab = [a, b]⇩∘" "a ∈⇩∘ 𝔄⦇Arr⦈" "b ∈⇩∘ 𝔅⦇Arr⦈"
from 𝔄 𝔅 prems(2,3) show "ab ∈⇩∘ (𝔄 ×⇩D⇩G 𝔅)⦇Arr⦈"
unfolding prems(1) dg_op_simps
by (cs_concl cs_simp: dg_cs_simps cs_intro: dg_prod_cs_intros)
next
fix ab a b assume prems: "ab = [a, b]⇩∘" "a ∈⇩∘ 𝔄⦇Arr⦈" "b ∈⇩∘ 𝔅⦇Arr⦈"
from 𝔄 𝔅 prems(2,3) show "ab ∈⇩∘ (𝔄 ×⇩D⇩G op_dg 𝔅)⦇Arr⦈"
unfolding prems(1) dg_op_simps
by (cs_concl cs_simp: dg_cs_simps cs_intro: dg_prod_cs_intros dg_op_intros)
qed
end
context
fixes α 𝔄 𝔅
assumes 𝔄: "digraph α 𝔄" and 𝔅: "digraph α 𝔅"
begin
lemma op_dg_dg_prod_2[dg_op_simps]: "op_dg (𝔄 ×⇩D⇩G 𝔅) = op_dg 𝔄 ×⇩D⇩G op_dg 𝔅"
proof(rule vsv_eqI)
show "vsv (op_dg (𝔄 ×⇩D⇩G 𝔅))" unfolding op_dg_def by auto
show "vsv (op_dg 𝔄 ×⇩D⇩G op_dg 𝔅)" unfolding dg_prod_2_def dg_prod_def by auto
have dom_lhs: "𝒟⇩∘ (op_dg (𝔄 ×⇩D⇩G 𝔅)) = 4⇩ℕ"
by (simp add: op_dg_def nat_omega_simps)
show "𝒟⇩∘ (op_dg (𝔄 ×⇩D⇩G 𝔅)) = 𝒟⇩∘ (op_dg 𝔄 ×⇩D⇩G op_dg 𝔅)"
unfolding dom_lhs by (simp add: dg_prod_2_def dg_prod_def nat_omega_simps)
have Cod_Dom: "(𝔄 ×⇩D⇩G 𝔅)⦇Cod⦈ = (op_dg 𝔄 ×⇩D⇩G op_dg 𝔅)⦇Dom⦈"
proof(rule vsv_eqI)
from 𝔄 𝔅 show "vsv ((𝔄 ×⇩D⇩G 𝔅)⦇Cod⦈)" by (rule dg_prod_2_Cod_vsv)
from 𝔄 𝔅 show "vsv ((op_dg 𝔄 ×⇩D⇩G op_dg 𝔅)⦇Dom⦈)"
by (cs_concl cs_intro: dg_prod_2_Dom_vsv dg_op_intros)+
from 𝔄 𝔅 have dom_lhs: "𝒟⇩∘ ((𝔄 ×⇩D⇩G 𝔅)⦇Cod⦈) = (𝔄 ×⇩D⇩G 𝔅)⦇Arr⦈"
by (cs_concl cs_simp: dg_cs_simps)
from 𝔄 𝔅 show "𝒟⇩∘ ((𝔄 ×⇩D⇩G 𝔅)⦇Cod⦈) = 𝒟⇩∘ ((op_dg 𝔄 ×⇩D⇩G op_dg 𝔅)⦇Dom⦈)"
unfolding dom_lhs
by (cs_concl cs_simp: dg_cs_simps dg_op_simps cs_intro: dg_op_intros)
show "(𝔄 ×⇩D⇩G 𝔅)⦇Cod⦈⦇gf⦈ = (op_dg 𝔄 ×⇩D⇩G op_dg 𝔅)⦇Dom⦈⦇gf⦈"
if "gf ∈⇩∘ 𝒟⇩∘ ((𝔄 ×⇩D⇩G 𝔅)⦇Cod⦈)" for gf
using that unfolding dom_lhs
proof-
assume "gf ∈⇩∘ (𝔄 ×⇩D⇩G 𝔅)⦇Arr⦈"
then obtain g f
where gf_def: "gf = [g, f]⇩∘"
and g: "g ∈⇩∘ 𝔄⦇Arr⦈"
and f: "f ∈⇩∘ 𝔅⦇Arr⦈"
by (rule dg_prod_2_ArrE[OF 𝔄 𝔅]) simp
from 𝔄 𝔅 g f show "(𝔄 ×⇩D⇩G 𝔅)⦇Cod⦈⦇gf⦈ = (op_dg 𝔄 ×⇩D⇩G op_dg 𝔅)⦇Dom⦈⦇gf⦈"
unfolding gf_def
by
(
cs_concl
cs_simp: dg_prod_cs_simps dg_op_simps
cs_intro: dg_prod_cs_intros dg_op_intros
)
qed
qed
have Dom_Cod: "(𝔄 ×⇩D⇩G 𝔅)⦇Dom⦈ = (op_dg 𝔄 ×⇩D⇩G op_dg 𝔅)⦇Cod⦈"
proof(rule vsv_eqI)
from 𝔄 𝔅 show "vsv ((op_dg 𝔄 ×⇩D⇩G op_dg 𝔅)⦇Cod⦈)"
by (cs_concl cs_intro: dg_prod_2_Cod_vsv dg_op_intros)+
from 𝔄 𝔅 have dom_lhs: "𝒟⇩∘ ((𝔄 ×⇩D⇩G 𝔅)⦇Dom⦈) = (𝔄 ×⇩D⇩G 𝔅)⦇Arr⦈"
by (cs_concl cs_simp: dg_cs_simps)
from 𝔄 𝔅 show "𝒟⇩∘ ((𝔄 ×⇩D⇩G 𝔅)⦇Dom⦈) = 𝒟⇩∘ ((op_dg 𝔄 ×⇩D⇩G op_dg 𝔅)⦇Cod⦈)"
unfolding dom_lhs
by (cs_concl cs_simp: dg_cs_simps dg_op_simps cs_intro: dg_op_intros)
show "(𝔄 ×⇩D⇩G 𝔅)⦇Dom⦈⦇gf⦈ = (op_dg 𝔄 ×⇩D⇩G op_dg 𝔅)⦇Cod⦈⦇gf⦈"
if "gf ∈⇩∘ 𝒟⇩∘ ((𝔄 ×⇩D⇩G 𝔅)⦇Dom⦈)" for gf
using that unfolding dom_lhs
proof-
assume "gf ∈⇩∘ (𝔄 ×⇩D⇩G 𝔅)⦇Arr⦈"
then obtain g f
where gf_def: "gf = [g, f]⇩∘"
and g: "g ∈⇩∘ 𝔄⦇Arr⦈"
and f: "f ∈⇩∘ 𝔅⦇Arr⦈"
by (rule dg_prod_2_ArrE[OF 𝔄 𝔅]) simp
from 𝔄 𝔅 g f show "(𝔄 ×⇩D⇩G 𝔅)⦇Dom⦈⦇gf⦈ = (op_dg 𝔄 ×⇩D⇩G op_dg 𝔅)⦇Cod⦈⦇gf⦈"
unfolding gf_def
by
(
cs_concl
cs_simp: dg_cs_simps dg_prod_cs_simps dg_op_simps
cs_intro: dg_op_intros dg_prod_cs_intros
)
qed
qed (auto intro: 𝔄 𝔅 dg_prod_2_Dom_vsv)
show "a ∈⇩∘ 𝒟⇩∘ (op_dg (𝔄 ×⇩D⇩G 𝔅)) ⟹
op_dg (𝔄 ×⇩D⇩G 𝔅)⦇a⦈ = (op_dg 𝔄 ×⇩D⇩G op_dg 𝔅)⦇a⦈"
for a
proof
(
unfold dom_lhs,
elim_in_numeral,
fold dg_field_simps,
unfold op_dg_components
)
from 𝔄 𝔅 show "(𝔄 ×⇩D⇩G 𝔅)⦇Obj⦈ = (op_dg 𝔄 ×⇩D⇩G op_dg 𝔅)⦇Obj⦈"
by (cs_concl cs_simp: dg_op_simps cs_intro: dg_op_intros)
from 𝔄 𝔅 show "(𝔄 ×⇩D⇩G 𝔅)⦇Arr⦈ = (op_dg 𝔄 ×⇩D⇩G op_dg 𝔅)⦇Arr⦈"
by (cs_concl cs_simp: dg_op_simps cs_intro: dg_op_intros)
qed (auto simp: 𝔄 𝔅 Cod_Dom Dom_Cod)
qed
end
subsection‹Projections for the product of two digraphs›
subsubsection‹Definition and elementary properties›
definition dghm_proj_fst :: "V ⇒ V ⇒ V" (‹π⇩D⇩G⇩.⇩1›)
where "π⇩D⇩G⇩.⇩1 𝔄 𝔅 = dghm_proj (2⇩ℕ) (if2 𝔄 𝔅) 0"
definition dghm_proj_snd :: "V ⇒ V ⇒ V" (‹π⇩D⇩G⇩.⇩2›)
where "π⇩D⇩G⇩.⇩2 𝔄 𝔅 = dghm_proj (2⇩ℕ) (if2 𝔄 𝔅) (1⇩ℕ)"
subsubsection‹Object map for a projection of a product of two digraphs›
context
fixes α 𝔄 𝔅
assumes 𝔄: "digraph α 𝔄" and 𝔅: "digraph α 𝔅"
begin
lemma dghm_proj_fst_ObjMap_app[dg_cs_simps]:
assumes "[a, b]⇩∘ ∈⇩∘ (𝔄 ×⇩D⇩G 𝔅)⦇Obj⦈"
shows "π⇩D⇩G⇩.⇩1 𝔄 𝔅⦇ObjMap⦈⦇a, b⦈⇩∙ = a"
proof-
from assms have "[a, b]⇩∘ ∈⇩∘ (∏⇩∘i∈⇩∘2⇩ℕ. (if i = 0 then 𝔄 else 𝔅)⦇Obj⦈)"
unfolding dg_prod_2_def dg_prod_components by simp
then show "π⇩D⇩G⇩.⇩1 𝔄 𝔅⦇ObjMap⦈⦇a, b⦈⇩∙ = a"
unfolding dghm_proj_fst_def dghm_proj_components dg_prod_components by simp
qed
lemma dghm_proj_snd_ObjMap_app[dg_cs_simps]:
assumes "[a, b]⇩∘ ∈⇩∘ (𝔄 ×⇩D⇩G 𝔅)⦇Obj⦈"
shows "π⇩D⇩G⇩.⇩2 𝔄 𝔅⦇ObjMap⦈⦇a, b⦈⇩∙ = b"
proof-
from assms have "[a, b]⇩∘ ∈⇩∘ (∏⇩∘i∈⇩∘2⇩ℕ. (if i = 0 then 𝔄 else 𝔅)⦇Obj⦈)"
unfolding dg_prod_2_def dg_prod_components by simp
then show "π⇩D⇩G⇩.⇩2 𝔄 𝔅⦇ObjMap⦈⦇a, b⦈⇩∙ = b"
unfolding dghm_proj_snd_def dghm_proj_components dg_prod_components
by (simp add: nat_omega_simps)
qed
end
subsubsection‹Arrow map for a projection of a product of two digraphs›
context
fixes α 𝔄 𝔅
assumes 𝔄: "digraph α 𝔄" and 𝔅: "digraph α 𝔅"
begin
lemma dghm_proj_fst_ArrMap_app[dg_cs_simps]:
assumes "[g, f]⇩∘ ∈⇩∘ (𝔄 ×⇩D⇩G 𝔅)⦇Arr⦈"
shows "π⇩D⇩G⇩.⇩1 𝔄 𝔅⦇ArrMap⦈⦇g, f⦈⇩∙ = g"
proof-
from assms have "[g, f]⇩∘ ∈⇩∘ (∏⇩∘i∈⇩∘2⇩ℕ. (if i = 0 then 𝔄 else 𝔅)⦇Arr⦈)"
unfolding dg_prod_2_def dg_prod_components by simp
then show "π⇩D⇩G⇩.⇩1 𝔄 𝔅⦇ArrMap⦈⦇g, f⦈⇩∙ = g"
unfolding dghm_proj_fst_def dghm_proj_components dg_prod_components by simp
qed
lemma dghm_proj_snd_ArrMap_app[dg_cs_simps]:
assumes "[g, f]⇩∘ ∈⇩∘ (𝔄 ×⇩D⇩G 𝔅)⦇Arr⦈"
shows "π⇩D⇩G⇩.⇩2 𝔄 𝔅⦇ArrMap⦈⦇g, f⦈⇩∙ = f"
proof-
from assms have "[g, f]⇩∘ ∈⇩∘ (∏⇩∘i∈⇩∘2⇩ℕ. (if i = 0 then 𝔄 else 𝔅)⦇Arr⦈)"
unfolding dg_prod_2_def dg_prod_components by simp
then show "π⇩D⇩G⇩.⇩2 𝔄 𝔅⦇ArrMap⦈⦇g, f⦈⇩∙ = f"
unfolding dghm_proj_snd_def dghm_proj_components dg_prod_components
by (simp add: nat_omega_simps)
qed
end
subsubsection‹Domain and codomain of a projection of a product of two digraphs›
lemma dghm_proj_fst_HomDom: "π⇩D⇩G⇩.⇩1 𝔄 𝔅⦇HomDom⦈ = 𝔄 ×⇩D⇩G 𝔅"
unfolding dghm_proj_fst_def dghm_proj_components dg_prod_2_def ..
lemma dghm_proj_fst_HomCod: "π⇩D⇩G⇩.⇩1 𝔄 𝔅⦇HomCod⦈ = 𝔄"
unfolding dghm_proj_fst_def dghm_proj_components dg_prod_2_def by simp
lemma dghm_proj_snd_HomDom: "π⇩D⇩G⇩.⇩2 𝔄 𝔅⦇HomDom⦈ = 𝔄 ×⇩D⇩G 𝔅"
unfolding dghm_proj_snd_def dghm_proj_components dg_prod_2_def ..
lemma dghm_proj_snd_HomCod: "π⇩D⇩G⇩.⇩2 𝔄 𝔅⦇HomCod⦈ = 𝔅"
unfolding dghm_proj_snd_def dghm_proj_components dg_prod_2_def by simp
subsubsection‹Projection of a product of two digraphs is a digraph homomorphism›
context
fixes α 𝔄 𝔅
assumes 𝔄: "digraph α 𝔄" and 𝔅: "digraph α 𝔅"
begin
interpretation finite_pdigraph α ‹2⇩ℕ› ‹if2 𝔄 𝔅›
by (intro finite_pdigraph_dg_prod_2 𝔄 𝔅)
lemma dghm_proj_fst_is_dghm:
assumes "i ∈⇩∘ I"
shows "π⇩D⇩G⇩.⇩1 𝔄 𝔅 : 𝔄 ×⇩D⇩G 𝔅 ↦↦⇩D⇩G⇘α⇙ 𝔄"
by
(
rule pdg_dghm_proj_is_dghm[
where i=0, simplified, folded dghm_proj_fst_def dg_prod_2_def
]
)
lemma dghm_proj_fst_is_dghm'[dg_cs_intros]:
assumes "i ∈⇩∘ I" and "ℭ = 𝔄 ×⇩D⇩G 𝔅" and "𝔇 = 𝔄"
shows "π⇩D⇩G⇩.⇩1 𝔄 𝔅 : ℭ ↦↦⇩D⇩G⇘α⇙ 𝔇"
using assms(1) unfolding assms(2,3) by (rule dghm_proj_fst_is_dghm)
lemma dghm_proj_snd_is_dghm:
assumes "i ∈⇩∘ I"
shows "π⇩D⇩G⇩.⇩2 𝔄 𝔅 : 𝔄 ×⇩D⇩G 𝔅 ↦↦⇩D⇩G⇘α⇙ 𝔅"
by
(
rule pdg_dghm_proj_is_dghm[
where i=‹1⇩ℕ›, simplified, folded dghm_proj_snd_def dg_prod_2_def
]
)
lemma dghm_proj_snd_is_dghm'[dg_cs_intros]:
assumes "i ∈⇩∘ I" and "ℭ = 𝔄 ×⇩D⇩G 𝔅" and "𝔇 = 𝔅"
shows "π⇩D⇩G⇩.⇩2 𝔄 𝔅 : ℭ ↦↦⇩D⇩G⇘α⇙ 𝔇"
using assms(1) unfolding assms(2,3) by (rule dghm_proj_snd_is_dghm)
end
subsection‹Product of three digraphs›
definition dg_prod_3 :: "V ⇒ V ⇒ V ⇒ V" ("(_ ×⇩D⇩G⇩3 _ ×⇩D⇩G⇩3 _)" [81, 81, 81] 80)
where "𝔄 ×⇩D⇩G⇩3 𝔅 ×⇩D⇩G⇩3 ℭ = (∏⇩D⇩Gi∈⇩∘3⇩ℕ. if3 𝔄 𝔅 ℭ i)"
subsubsection‹Product of three digraphs is a digraph›
context
fixes α 𝔄 𝔅 ℭ
assumes 𝔄: "digraph α 𝔄" and 𝔅: "digraph α 𝔅" and ℭ: "digraph α ℭ"
begin
interpretation 𝒵 α by (rule digraphD[OF 𝔄(1)])
interpretation 𝔄: digraph α 𝔄 by (rule 𝔄)
interpretation 𝔅: digraph α 𝔅 by (rule 𝔅)
interpretation 𝔅: digraph α ℭ by (rule ℭ)
lemma finite_pdigraph_dg_prod_3:
"finite_pdigraph α (3⇩ℕ) (if3 𝔄 𝔅 ℭ)"
proof(intro finite_pdigraphI pdigraph_baseI)
from Axiom_of_Infinity show z1_in_Vset: "3⇩ℕ ∈⇩∘ Vset α" by blast
show "digraph α (if3 𝔄 𝔅 ℭ i)" if "i ∈⇩∘ 3⇩ℕ" for i
by (auto intro: dg_cs_intros)
qed auto
interpretation finite_pdigraph α ‹3⇩ℕ› ‹if3 𝔄 𝔅 ℭ›
by (intro finite_pdigraph_dg_prod_3 𝔄 𝔅)
lemma digraph_dg_prod_3[dg_cs_intros]: "digraph α (𝔄 ×⇩D⇩G⇩3 𝔅 ×⇩D⇩G⇩3 ℭ)"
proof-
show ?thesis unfolding dg_prod_3_def by (rule pdg_digraph_dg_prod)
qed
end
subsubsection‹Object›
context
fixes α 𝔄 𝔅 ℭ
assumes 𝔄: "digraph α 𝔄" and 𝔅: "digraph α 𝔅" and ℭ: "digraph α ℭ"
begin
lemma dg_prod_3_ObjI:
assumes "a ∈⇩∘ 𝔄⦇Obj⦈" and "b ∈⇩∘ 𝔅⦇Obj⦈" and "c ∈⇩∘ ℭ⦇Obj⦈"
shows "[a, b, c]⇩∘ ∈⇩∘ (𝔄 ×⇩D⇩G⇩3 𝔅 ×⇩D⇩G⇩3 ℭ)⦇Obj⦈"
unfolding dg_prod_3_def dg_prod_components
proof(intro vproductI ballI)
show "𝒟⇩∘ [a, b, c]⇩∘ = 3⇩ℕ" by (simp add: nat_omega_simps)
fix i assume "i ∈⇩∘ 3⇩ℕ"
then consider ‹i = 0› | ‹i = 1⇩ℕ› | ‹i = 2⇩ℕ› unfolding three by auto
then show "[a, b, c]⇩∘⦇i⦈ ∈⇩∘ (if3 𝔄 𝔅 ℭ i)⦇Obj⦈"
by cases (simp_all add: nat_omega_simps assms)
qed auto
lemma dg_prod_3_ObjI'[dg_prod_cs_intros]:
assumes "abc = [a, b, c]⇩∘" and "a ∈⇩∘ 𝔄⦇Obj⦈" and "b ∈⇩∘ 𝔅⦇Obj⦈" and "c ∈⇩∘ ℭ⦇Obj⦈"
shows "abc ∈⇩∘ (𝔄 ×⇩D⇩G⇩3 𝔅 ×⇩D⇩G⇩3 ℭ)⦇Obj⦈"
using assms(2-4) unfolding assms(1) by (rule dg_prod_3_ObjI)
lemma dg_prod_3_ObjE:
assumes "abc ∈⇩∘ (𝔄 ×⇩D⇩G⇩3 𝔅 ×⇩D⇩G⇩3 ℭ)⦇Obj⦈"
obtains a b c
where "abc = [a, b, c]⇩∘"
and "a ∈⇩∘ 𝔄⦇Obj⦈"
and "b ∈⇩∘ 𝔅⦇Obj⦈"
and "c ∈⇩∘ ℭ⦇Obj⦈"
proof-
from vproductD[OF assms[unfolded dg_prod_3_def dg_prod_components]]
have vsv_abc: "vsv abc"
and dom_abc: "𝒟⇩∘ abc = 3⇩ℕ"
and abc_app: "⋀i. i ∈⇩∘ 3⇩ℕ ⟹ abc⦇i⦈ ∈⇩∘ (if3 𝔄 𝔅 ℭ i)⦇Obj⦈"
by auto
have dom_abc[simp]: "𝒟⇩∘ abc = 3⇩ℕ"
unfolding dom_abc by (simp add: nat_omega_simps two)
interpret vsv abc by (rule vsv_abc)
have "abc = [vpfst abc, vpsnd abc, vpthrd abc]⇩∘"
by (rule vsv_vfsequence_three[symmetric]) auto
moreover from abc_app[of 0] have "vpfst abc ∈⇩∘ 𝔄⦇Obj⦈" by simp
moreover from abc_app[of ‹1⇩ℕ›] have "vpsnd abc ∈⇩∘ 𝔅⦇Obj⦈" by simp
moreover from abc_app[of ‹2⇩ℕ›] have "vpthrd abc ∈⇩∘ ℭ⦇Obj⦈" by simp
ultimately show ?thesis using that by auto
qed
end
subsubsection‹Arrow›
context
fixes α 𝔄 𝔅 ℭ
assumes 𝔄: "digraph α 𝔄" and 𝔅: "digraph α 𝔅" and ℭ: "digraph α ℭ"
begin
lemma dg_prod_3_ArrI:
assumes "h ∈⇩∘ 𝔄⦇Arr⦈" and "g ∈⇩∘ 𝔅⦇Arr⦈" and "f ∈⇩∘ ℭ⦇Arr⦈"
shows "[h, g, f]⇩∘ ∈⇩∘ (𝔄 ×⇩D⇩G⇩3 𝔅 ×⇩D⇩G⇩3 ℭ)⦇Arr⦈"
unfolding dg_prod_3_def dg_prod_components
proof(intro vproductI ballI)
show "𝒟⇩∘ [h, g, f]⇩∘ = 3⇩ℕ" by (simp add: nat_omega_simps three)
fix i assume "i ∈⇩∘ 3⇩ℕ"
then consider ‹i = 0› | ‹i = 1⇩ℕ› | ‹i = 2⇩ℕ› unfolding three by auto
then show "[h, g, f]⇩∘⦇i⦈ ∈⇩∘ (if3 𝔄 𝔅 ℭ i)⦇Arr⦈"
by cases (simp_all add: nat_omega_simps assms)
qed auto
lemma dg_prod_3_ArrI'[dg_prod_cs_intros]:
assumes "hgf = [h, g, f]⇩∘"
and "h ∈⇩∘ 𝔄⦇Arr⦈"
and "g ∈⇩∘ 𝔅⦇Arr⦈"
and "f ∈⇩∘ ℭ⦇Arr⦈"
shows "[h, g, f]⇩∘ ∈⇩∘ (𝔄 ×⇩D⇩G⇩3 𝔅 ×⇩D⇩G⇩3 ℭ)⦇Arr⦈"
using assms(2-4) unfolding assms(1) by (rule dg_prod_3_ArrI)
lemma dg_prod_3_ArrE:
assumes "hgf ∈⇩∘ (𝔄 ×⇩D⇩G⇩3 𝔅 ×⇩D⇩G⇩3 ℭ)⦇Arr⦈"
obtains h g f
where "hgf = [h, g, f]⇩∘"
and "h ∈⇩∘ 𝔄⦇Arr⦈"
and "g ∈⇩∘ 𝔅⦇Arr⦈"
and "f ∈⇩∘ ℭ⦇Arr⦈"
proof-
from vproductD[OF assms[unfolded dg_prod_3_def dg_prod_components]]
have vsv_hgf: "vsv hgf"
and dom_hgf: "𝒟⇩∘ hgf = 3⇩ℕ"
and hgf_app: "⋀i. i ∈⇩∘ 3⇩ℕ ⟹ hgf⦇i⦈ ∈⇩∘ (if3 𝔄 𝔅 ℭ i)⦇Arr⦈"
by auto
have dom_hgf[simp]: "𝒟⇩∘ hgf = 3⇩ℕ" unfolding dom_hgf by (simp add: three)
interpret vsv hgf by (rule vsv_hgf)
have "hgf = [vpfst hgf, vpsnd hgf, vpthrd hgf]⇩∘"
by (rule vsv_vfsequence_three[symmetric]) auto
moreover from hgf_app[of 0] have "vpfst hgf ∈⇩∘ 𝔄⦇Arr⦈" by simp
moreover from hgf_app[of ‹1⇩ℕ›] have "vpsnd hgf ∈⇩∘ 𝔅⦇Arr⦈" by simp
moreover from hgf_app[of ‹2⇩ℕ›] have "vpthrd hgf ∈⇩∘ ℭ⦇Arr⦈" by simp
ultimately show ?thesis using that by auto
qed
end
subsubsection‹Arrow with a domain and a codomain›
context
fixes α 𝔄 𝔅 ℭ
assumes 𝔄: "digraph α 𝔄" and 𝔅: "digraph α 𝔅" and ℭ: "digraph α ℭ"
begin
interpretation 𝒵 α by (rule digraphD[OF 𝔄(1)])
interpretation 𝔄: digraph α 𝔄 by (rule 𝔄)
interpretation 𝔅: digraph α 𝔅 by (rule 𝔅)
interpretation ℭ: digraph α ℭ by (rule ℭ)
interpretation finite_pdigraph α ‹3⇩ℕ› ‹if3 𝔄 𝔅 ℭ›
by (intro finite_pdigraph_dg_prod_3 𝔄 𝔅 ℭ)
lemma dg_prod_3_is_arrI:
assumes "f : a ↦⇘𝔄⇙ b" and "f' : a' ↦⇘𝔅⇙ b'" and "f'' : a'' ↦⇘ℭ⇙ b''"
shows "[f, f', f'']⇩∘ : [a, a', a'']⇩∘ ↦⇘𝔄 ×⇩D⇩G⇩3 𝔅 ×⇩D⇩G⇩3 ℭ⇙ [b, b', b'']⇩∘"
unfolding dg_prod_3_def
proof(rule dg_prod_is_arrI)
show "[f, f', f'']⇩∘⦇i⦈ : [a, a', a'']⇩∘⦇i⦈ ↦⇘if3 𝔄 𝔅 ℭ i⇙ [b, b', b'']⇩∘⦇i⦈"
if "i ∈⇩∘ 3⇩ℕ" for i
proof-
from that consider ‹i = 0› | ‹i = 1⇩ℕ› | ‹i = 2⇩ℕ› unfolding three by auto
then show
"[f, f', f'']⇩∘⦇i⦈ : [a, a', a'']⇩∘⦇i⦈ ↦⇘if3 𝔄 𝔅 ℭ i⇙ [b, b', b'']⇩∘⦇i⦈"
by cases (simp_all add: nat_omega_simps assms)
qed
qed (auto simp: nat_omega_simps three)
lemma dg_prod_3_is_arrI'[dg_prod_cs_intros]:
assumes "F = [f, f', f'']⇩∘"
and "A = [a, a', a'']⇩∘"
and "B = [b, b', b'']⇩∘"
and "f : a ↦⇘𝔄⇙ b"
and "f' : a' ↦⇘𝔅⇙ b'"
and "f'' : a'' ↦⇘ℭ⇙ b''"
shows "F : A ↦⇘𝔄 ×⇩D⇩G⇩3 𝔅 ×⇩D⇩G⇩3 ℭ⇙ B"
using assms(4,5,6) unfolding assms(1,2,3) by (rule dg_prod_3_is_arrI)
lemma dg_prod_3_is_arrE:
assumes "F : A ↦⇘𝔄 ×⇩D⇩G⇩3 𝔅 ×⇩D⇩G⇩3 ℭ⇙ B"
obtains f f' f'' a a' a'' b b' b''
where "F = [f, f', f'']⇩∘"
and "A = [a, a', a'']⇩∘"
and "B = [b, b', b'']⇩∘"
and "f : a ↦⇘𝔄⇙ b"
and "f' : a' ↦⇘𝔅⇙ b'"
and "f'' : a'' ↦⇘ℭ⇙ b''"
proof-
from dg_prod_is_arrD[OF assms[unfolded dg_prod_3_def]]
have [simp]: "vsv F" "𝒟⇩∘ F = 3⇩ℕ" "vsv A" "𝒟⇩∘ A = 3⇩ℕ" "vsv B" "𝒟⇩∘ B = 3⇩ℕ"
and F_app: "⋀i. i ∈⇩∘ 3⇩ℕ ⟹ F⦇i⦈ : A⦇i⦈ ↦⇘if3 𝔄 𝔅 ℭ i⇙ B⦇i⦈"
by (auto simp: three)
have "F = [vpfst F, vpsnd F, vpthrd F]⇩∘"
by (simp add: vsv_vfsequence_three)
moreover have "A = [vpfst A, vpsnd A, vpthrd A]⇩∘"
by (simp add: vsv_vfsequence_three)
moreover have "B = [vpfst B, vpsnd B, vpthrd B]⇩∘"
by (simp add: vsv_vfsequence_three)
moreover from F_app[of 0] have "vpfst F : vpfst A ↦⇘𝔄⇙ vpfst B" by simp
moreover from F_app[of ‹1⇩ℕ›] have "vpsnd F : vpsnd A ↦⇘𝔅⇙ vpsnd B"
by (simp add: nat_omega_simps)
moreover from F_app[of ‹2⇩ℕ›] have "vpthrd F : vpthrd A ↦⇘ℭ⇙ vpthrd B"
by (simp add: nat_omega_simps)
ultimately show ?thesis using that by auto
qed
end
subsubsection‹Domain›
context
fixes α 𝔄 𝔅 ℭ
assumes 𝔄: "digraph α 𝔄" and 𝔅: "digraph α 𝔅" and ℭ: "digraph α ℭ"
begin
interpretation 𝒵 α by (rule digraphD[OF 𝔄(1)])
interpretation 𝔄: digraph α 𝔄 by (rule 𝔄)
interpretation 𝔅: digraph α 𝔅 by (rule 𝔅)
interpretation ℭ: digraph α ℭ by (rule ℭ)
lemma dg_prod_3_Dom_vsv: "vsv ((𝔄 ×⇩D⇩G⇩3 𝔅 ×⇩D⇩G⇩3 ℭ)⦇Dom⦈)"
unfolding dg_prod_3_def dg_prod_components by simp
lemma dg_prod_3_Dom_vdomain[dg_cs_simps]:
"𝒟⇩∘ ((𝔄 ×⇩D⇩G⇩3 𝔅 ×⇩D⇩G⇩3 ℭ)⦇Dom⦈) = (𝔄 ×⇩D⇩G⇩3 𝔅 ×⇩D⇩G⇩3 ℭ)⦇Arr⦈"
unfolding dg_prod_3_def dg_prod_components by simp
lemma dg_prod_3_Dom_app[dg_prod_cs_simps]:
assumes "[f, f', f'']⇩∘ ∈⇩∘ (𝔄 ×⇩D⇩G⇩3 𝔅 ×⇩D⇩G⇩3 ℭ)⦇Arr⦈"
shows "(𝔄 ×⇩D⇩G⇩3 𝔅 ×⇩D⇩G⇩3 ℭ)⦇Dom⦈⦇f, f', f''⦈⇩∙ =
[𝔄⦇Dom⦈⦇f⦈, 𝔅⦇Dom⦈⦇f'⦈, ℭ⦇Dom⦈⦇f''⦈]⇩∘"
proof-
from assms obtain A B where F: "[f, f', f'']⇩∘ : A ↦⇘𝔄 ×⇩D⇩G⇩3 𝔅 ×⇩D⇩G⇩3 ℭ⇙ B"
by (auto intro: is_arrI)
then have Dom_F: "(𝔄 ×⇩D⇩G⇩3 𝔅 ×⇩D⇩G⇩3 ℭ)⦇Dom⦈⦇f, f', f''⦈⇩∙ = A"
by (simp add: dg_cs_simps)
from F obtain a a' a'' b b' b''
where A_def: "A = [a, a', a'']⇩∘"
and "B = [b, b', b'']⇩∘"
and "f : a ↦⇘𝔄⇙ b"
and "f' : a' ↦⇘𝔅⇙ b'"
and "f'' : a'' ↦⇘ℭ⇙ b''"
by (elim dg_prod_3_is_arrE[OF 𝔄 𝔅 ℭ]) simp
then have Dom_f: "𝔄⦇Dom⦈⦇f⦈ = a"
and Dom_f': "𝔅⦇Dom⦈⦇f'⦈ = a'"
and Dom_f'': "ℭ⦇Dom⦈⦇f''⦈ = a''"
by (simp_all add: dg_cs_simps)
show ?thesis unfolding Dom_F A_def Dom_f Dom_f' Dom_f'' ..
qed
lemma dg_prod_3_Dom_vrange:
"ℛ⇩∘ ((𝔄 ×⇩D⇩G⇩3 𝔅 ×⇩D⇩G⇩3 ℭ)⦇Dom⦈) ⊆⇩∘ (𝔄 ×⇩D⇩G⇩3 𝔅 ×⇩D⇩G⇩3 ℭ)⦇Obj⦈"
proof(rule vsv.vsv_vrange_vsubset, unfold dg_cs_simps)
show "vsv ((𝔄 ×⇩D⇩G⇩3 𝔅 ×⇩D⇩G⇩3 ℭ)⦇Dom⦈)" by (rule dg_prod_3_Dom_vsv)
fix F assume prems: "F ∈⇩∘ (𝔄 ×⇩D⇩G⇩3 𝔅 ×⇩D⇩G⇩3 ℭ)⦇Arr⦈"
then obtain f f' f'' where F_def: "F = [f, f', f'']⇩∘"
and f: "f ∈⇩∘ 𝔄⦇Arr⦈"
and f': "f' ∈⇩∘ 𝔅⦇Arr⦈"
and f'': "f'' ∈⇩∘ ℭ⦇Arr⦈"
by (elim dg_prod_3_ArrE[OF 𝔄 𝔅 ℭ]) simp
from f f' f'' obtain a a' a'' b b' b''
where f: "f : a ↦⇘𝔄⇙ b"
and f': "f' : a' ↦⇘𝔅⇙ b'"
and f'': "f'' : a'' ↦⇘ℭ⇙ b''"
by (meson is_arrI)
from 𝔄 𝔅 f f' f'' show "(𝔄 ×⇩D⇩G⇩3 𝔅 ×⇩D⇩G⇩3 ℭ)⦇Dom⦈⦇F⦈ ∈⇩∘ (𝔄 ×⇩D⇩G⇩3 𝔅 ×⇩D⇩G⇩3 ℭ)⦇Obj⦈"
unfolding F_def dg_prod_3_Dom_app[OF prems[unfolded F_def]]
by (cs_concl cs_simp: dg_cs_simps cs_intro: dg_cs_intros dg_prod_cs_intros)
qed
end
subsubsection‹Codomain›
context
fixes α 𝔄 𝔅 ℭ
assumes 𝔄: "digraph α 𝔄" and 𝔅: "digraph α 𝔅" and ℭ: "digraph α ℭ"
begin
interpretation 𝒵 α by (rule digraphD[OF 𝔄(1)])
interpretation 𝔄: digraph α 𝔄 by (rule 𝔄)
interpretation 𝔅: digraph α 𝔅 by (rule 𝔅)
interpretation ℭ: digraph α ℭ by (rule ℭ)
lemma dg_prod_3_Cod_vsv: "vsv ((𝔄 ×⇩D⇩G⇩3 𝔅 ×⇩D⇩G⇩3 ℭ)⦇Cod⦈)"
unfolding dg_prod_3_def dg_prod_components by simp
lemma dg_prod_3_Cod_vdomain[dg_cs_simps]:
"𝒟⇩∘ ((𝔄 ×⇩D⇩G⇩3 𝔅 ×⇩D⇩G⇩3 ℭ)⦇Cod⦈) = (𝔄 ×⇩D⇩G⇩3 𝔅 ×⇩D⇩G⇩3 ℭ)⦇Arr⦈"
unfolding dg_prod_3_def dg_prod_components by simp
lemma dg_prod_3_Cod_app[dg_prod_cs_simps]:
assumes "[f, f', f'']⇩∘ ∈⇩∘ (𝔄 ×⇩D⇩G⇩3 𝔅 ×⇩D⇩G⇩3 ℭ)⦇Arr⦈"
shows
"(𝔄 ×⇩D⇩G⇩3 𝔅 ×⇩D⇩G⇩3 ℭ)⦇Cod⦈⦇f, f', f''⦈⇩∙ =
[𝔄⦇Cod⦈⦇f⦈, 𝔅⦇Cod⦈⦇f'⦈, ℭ⦇Cod⦈⦇f''⦈]⇩∘"
proof-
from assms obtain A B where F: "[f, f', f'']⇩∘ : A ↦⇘𝔄 ×⇩D⇩G⇩3 𝔅 ×⇩D⇩G⇩3 ℭ⇙ B"
by (auto intro: is_arrI)
then have Cod_F: "(𝔄 ×⇩D⇩G⇩3 𝔅 ×⇩D⇩G⇩3 ℭ)⦇Cod⦈⦇f, f', f''⦈⇩∙ = B"
by (simp add: dg_cs_simps)
from F obtain a a' a'' b b' b''
where "A = [a, a', a'']⇩∘"
and B_def: "B = [b, b', b'']⇩∘"
and "f : a ↦⇘𝔄⇙ b"
and "f' : a' ↦⇘𝔅⇙ b'"
and "f'' : a'' ↦⇘ℭ⇙ b''"
by (elim dg_prod_3_is_arrE[OF 𝔄 𝔅 ℭ]) simp
then have Cod_f: "𝔄⦇Cod⦈⦇f⦈ = b"
and Cod_f': "𝔅⦇Cod⦈⦇f'⦈ = b'"
and Cod_f'': "ℭ⦇Cod⦈⦇f''⦈ = b''"
by (simp_all add: dg_cs_simps)
show ?thesis unfolding Cod_F B_def Cod_f Cod_f' Cod_f'' ..
qed
lemma dg_prod_3_Cod_vrange:
"ℛ⇩∘ ((𝔄 ×⇩D⇩G⇩3 𝔅 ×⇩D⇩G⇩3 ℭ)⦇Cod⦈) ⊆⇩∘ (𝔄 ×⇩D⇩G⇩3 𝔅 ×⇩D⇩G⇩3 ℭ)⦇Obj⦈"
proof(rule vsv.vsv_vrange_vsubset, unfold dg_cs_simps)
show "vsv ((𝔄 ×⇩D⇩G⇩3 𝔅 ×⇩D⇩G⇩3 ℭ)⦇Cod⦈)" by (rule dg_prod_3_Cod_vsv)
fix F assume prems: "F ∈⇩∘ (𝔄 ×⇩D⇩G⇩3 𝔅 ×⇩D⇩G⇩3 ℭ)⦇Arr⦈"
then obtain f f' f'' where F_def: "F = [f, f', f'']⇩∘"
and f: "f ∈⇩∘ 𝔄⦇Arr⦈"
and f': "f' ∈⇩∘ 𝔅⦇Arr⦈"
and f'': "f'' ∈⇩∘ ℭ⦇Arr⦈"
by (elim dg_prod_3_ArrE[OF 𝔄 𝔅 ℭ]) simp
from f f' f'' obtain a a' a'' b b' b''
where f: "f : a ↦⇘𝔄⇙ b"
and f': "f' : a' ↦⇘𝔅⇙ b'"
and f'': "f'' : a'' ↦⇘ℭ⇙ b''"
by (metis is_arrI)
from 𝔄 𝔅 ℭ f f' f'' show
"(𝔄 ×⇩D⇩G⇩3 𝔅 ×⇩D⇩G⇩3 ℭ)⦇Cod⦈⦇F⦈ ∈⇩∘ (𝔄 ×⇩D⇩G⇩3 𝔅 ×⇩D⇩G⇩3 ℭ)⦇Obj⦈"
unfolding F_def dg_prod_3_Cod_app[OF prems[unfolded F_def]]
by (cs_concl cs_simp: dg_cs_simps cs_intro: dg_cs_intros dg_prod_cs_intros)
qed
end
text‹\newpage›
end
Theory CZH_DG_Subdigraph
section‹Subdigraph›
theory CZH_DG_Subdigraph
imports
CZH_DG_Digraph
CZH_DG_DGHM
begin
subsection‹Background›
text‹
In this body of work, a subdigraph is a natural generalization of the concept
of a subcategory, as defined in Chapter I-3 in \cite{mac_lane_categories_2010},
to digraphs.
It should be noted that a similar concept also exists in the conventional
graph theory, but further details are considered to be outside of the scope of
this work.
›
named_theorems dg_sub_cs_intros
named_theorems dg_sub_bw_cs_intros
named_theorems dg_sub_fw_cs_intros
named_theorems dg_sub_bw_cs_simps
subsection‹Simple subdigraph›
subsubsection‹Definition and elementary properties›
locale subdigraph = sdg: digraph α 𝔅 + dg: digraph α ℭ for α 𝔅 ℭ +
assumes subdg_Obj_vsubset[dg_sub_fw_cs_intros]:
"a ∈⇩∘ 𝔅⦇Obj⦈ ⟹ a ∈⇩∘ ℭ⦇Obj⦈"
and subdg_is_arr_vsubset[dg_sub_fw_cs_intros]:
"f : a ↦⇘𝔅⇙ b ⟹ f : a ↦⇘ℭ⇙ b"
abbreviation is_subdigraph ("(_/ ⊆⇩D⇩Gı _)" [51, 51] 50)
where "𝔅 ⊆⇩D⇩G⇘α⇙ ℭ ≡ subdigraph α 𝔅 ℭ"
lemmas [dg_sub_fw_cs_intros] =
subdigraph.subdg_Obj_vsubset
subdigraph.subdg_is_arr_vsubset
text‹Rules.›
lemma (in subdigraph) subdigraph_axioms'[dg_cs_intros]:
assumes "α' = α" and "𝔅' = 𝔅"
shows "𝔅' ⊆⇩D⇩G⇘α'⇙ ℭ"
unfolding assms by (rule subdigraph_axioms)
lemma (in subdigraph) subdigraph_axioms''[dg_cs_intros]:
assumes "α' = α" and "ℭ' = ℭ"
shows "𝔅 ⊆⇩D⇩G⇘α'⇙ ℭ'"
unfolding assms by (rule subdigraph_axioms)
mk_ide rf subdigraph_def[unfolded subdigraph_axioms_def]
|intro subdigraphI|
|dest subdigraphD[dest]|
|elim subdigraphE[elim!]|
lemmas [dg_sub_cs_intros] = subdigraphD(1,2)
text‹The opposite subdigraph.›
lemma (in subdigraph) subdg_subdigraph_op_dg_op_dg: "op_dg 𝔅 ⊆⇩D⇩G⇘α⇙ op_dg ℭ"
proof(rule subdigraphI)
show "a ∈⇩∘ op_dg 𝔅⦇Obj⦈ ⟹ a ∈⇩∘ op_dg ℭ⦇Obj⦈" for a
by (auto simp: dg_op_simps subdg_Obj_vsubset)
show "f : a ↦⇘op_dg 𝔅⇙ b ⟹ f : a ↦⇘op_dg ℭ⇙ b" for f a b
by (auto simp: dg_op_simps subdg_is_arr_vsubset)
qed (auto simp: dg_op_simps intro: dg_op_intros)
lemmas subdg_subdigraph_op_dg_op_dg[dg_op_intros] =
subdigraph.subdg_subdigraph_op_dg_op_dg
text‹Further rules.›
lemma (in subdigraph) subdg_objD:
assumes "a ∈⇩∘ 𝔅⦇Obj⦈"
shows "a ∈⇩∘ ℭ⦇Obj⦈"
using assms by (auto intro: subdg_Obj_vsubset)
lemmas [dg_sub_fw_cs_intros] = subdigraph.subdg_objD
lemma (in subdigraph) subdg_arrD[dg_sub_fw_cs_intros]:
assumes "f ∈⇩∘ 𝔅⦇Arr⦈"
shows "f ∈⇩∘ ℭ⦇Arr⦈"
proof-
from assms obtain a b where "f : a ↦⇘𝔅⇙ b" by auto
then show "f ∈⇩∘ ℭ⦇Arr⦈"
by (cs_concl cs_intro: subdg_is_arr_vsubset dg_cs_intros)
qed
lemmas [dg_sub_fw_cs_intros] = subdigraph.subdg_arrD
lemma (in subdigraph) subdg_dom_simp:
assumes "f ∈⇩∘ 𝔅⦇Arr⦈"
shows "𝔅⦇Dom⦈⦇f⦈ = ℭ⦇Dom⦈⦇f⦈"
proof-
from assms obtain a b where "f : a ↦⇘𝔅⇙ b" by auto
then show "𝔅⦇Dom⦈⦇f⦈ = ℭ⦇Dom⦈⦇f⦈"
by (force dest: subdg_is_arr_vsubset simp: dg_cs_simps)
qed
lemmas [dg_sub_bw_cs_simps] = subdigraph.subdg_dom_simp
lemma (in subdigraph) subdg_cod_simp:
assumes "f ∈⇩∘ 𝔅⦇Arr⦈"
shows "𝔅⦇Cod⦈⦇f⦈ = ℭ⦇Cod⦈⦇f⦈"
proof-
from assms obtain a b where "f : a ↦⇘𝔅⇙ b" by auto
then show "𝔅⦇Cod⦈⦇f⦈ = ℭ⦇Cod⦈⦇f⦈"
by (force dest: subdg_is_arr_vsubset simp: dg_cs_simps)
qed
lemmas [dg_sub_bw_cs_simps] = subdigraph.subdg_cod_simp
lemma (in subdigraph) subdg_is_arrD:
assumes "f : a ↦⇘𝔅⇙ b"
shows "f : a ↦⇘ℭ⇙ b"
using assms subdg_is_arr_vsubset by simp
lemmas [dg_sub_fw_cs_intros] = subdigraph.subdg_is_arrD
subsubsection‹The subdigraph relation is a partial order›
lemma subdg_refl:
assumes "digraph α 𝔄"
shows "𝔄 ⊆⇩D⇩G⇘α⇙ 𝔄"
proof-
interpret digraph α 𝔄 by (rule assms)
show ?thesis by unfold_locales simp
qed
lemma subdg_trans[trans]:
assumes "𝔄 ⊆⇩D⇩G⇘α⇙ 𝔅" and "𝔅 ⊆⇩D⇩G⇘α⇙ ℭ"
shows "𝔄 ⊆⇩D⇩G⇘α⇙ ℭ"
proof-
interpret 𝔄𝔅: subdigraph α 𝔄 𝔅 by (rule assms(1))
interpret 𝔅ℭ: subdigraph α 𝔅 ℭ by (rule assms(2))
show ?thesis
by unfold_locales
(
insert 𝔄𝔅.subdigraph_axioms,
auto simp:
𝔅ℭ.subdg_Obj_vsubset
𝔄𝔅.subdg_Obj_vsubset
subdigraph.subdg_is_arr_vsubset
𝔅ℭ.subdg_is_arr_vsubset
)
qed
lemma subdg_antisym:
assumes "𝔄 ⊆⇩D⇩G⇘α⇙ 𝔅" and "𝔅 ⊆⇩D⇩G⇘α⇙ 𝔄"
shows "𝔄 = 𝔅"
proof-
interpret 𝔄𝔅: subdigraph α 𝔄 𝔅 by (rule assms(1))
interpret 𝔅𝔄: subdigraph α 𝔅 𝔄 by (rule assms(2))
show ?thesis
proof(rule dg_eqI)
from assms show Arr: "𝔄⦇Arr⦈ = 𝔅⦇Arr⦈"
by (intro vsubset_antisym vsubsetI)
(auto simp: dg_sub_bw_cs_simps intro: dg_sub_fw_cs_intros)
from assms show "𝔄⦇Obj⦈ = 𝔅⦇Obj⦈"
by (intro vsubset_antisym vsubsetI)
(auto simp: dg_sub_bw_cs_simps intro: dg_sub_fw_cs_intros)
show "𝔄⦇Dom⦈ = 𝔅⦇Dom⦈"
by (rule vsv_eqI) (auto simp: 𝔄𝔅.subdg_dom_simp Arr dg_cs_simps)
show "𝔄⦇Cod⦈ = 𝔅⦇Cod⦈"
by (rule vsv_eqI) (auto simp: 𝔄𝔅.subdg_cod_simp Arr dg_cs_simps)
qed (cs_concl cs_intro: dg_cs_intros)+
qed
subsection‹Inclusion digraph homomorphism›
subsubsection‹Definition and elementary properties›
text‹See Chapter I-3 in \cite{mac_lane_categories_2010}.›
definition dghm_inc :: "V ⇒ V ⇒ V"
where "dghm_inc 𝔅 ℭ = [vid_on (𝔅⦇Obj⦈), vid_on (𝔅⦇Arr⦈), 𝔅, ℭ]⇩∘"
text‹Components.›
lemma dghm_inc_components:
shows "dghm_inc 𝔅 ℭ⦇ObjMap⦈ = vid_on (𝔅⦇Obj⦈)"
and "dghm_inc 𝔅 ℭ⦇ArrMap⦈ = vid_on (𝔅⦇Arr⦈)"
and [dg_cs_simps]: "dghm_inc 𝔅 ℭ⦇HomDom⦈ = 𝔅"
and [dg_cs_simps]: "dghm_inc 𝔅 ℭ⦇HomCod⦈ = ℭ"
unfolding dghm_inc_def dghm_field_simps by (simp_all add: nat_omega_simps)
subsubsection‹Object map›
mk_VLambda dghm_inc_components(1)[folded VLambda_vid_on]
|vsv dghm_inc_ObjMap_vsv[dg_cs_intros]|
|vdomain dghm_inc_ObjMap_vdomain[dg_cs_simps]|
|app dghm_inc_ObjMap_app[dg_cs_simps]|
subsubsection‹Arrow map›
mk_VLambda dghm_inc_components(2)[folded VLambda_vid_on]
|vsv dghm_inc_ArrMap_vsv[dg_cs_intros]|
|vdomain dghm_inc_ArrMap_vdomain[dg_cs_simps]|
|app dghm_inc_ArrMap_app[dg_cs_simps]|
subsubsection‹
Canonical inclusion digraph homomorphism associated with a subdigraph
›
sublocale subdigraph ⊆ inc: is_ft_dghm α 𝔅 ℭ ‹dghm_inc 𝔅 ℭ›
proof(intro is_ft_dghmI is_dghmI)
show "vfsequence (dghm_inc 𝔅 ℭ)" unfolding dghm_inc_def by auto
show "vcard (dghm_inc 𝔅 ℭ) = 4⇩ℕ"
unfolding dghm_inc_def by (simp add: nat_omega_simps)
show "ℛ⇩∘ (dghm_inc 𝔅 ℭ⦇ObjMap⦈) ⊆⇩∘ ℭ⦇Obj⦈"
unfolding dghm_inc_components by (auto dest: subdg_objD)
show "dghm_inc 𝔅 ℭ⦇ArrMap⦈⦇f⦈ :
dghm_inc 𝔅 ℭ⦇ObjMap⦈⦇a⦈ ↦⇘ℭ⇙ dghm_inc 𝔅 ℭ⦇ObjMap⦈⦇b⦈"
if "f : a ↦⇘𝔅⇙ b" for a b f
using that
by (cs_concl cs_simp: dg_cs_simps cs_intro: dg_cs_intros dg_sub_fw_cs_intros)
show "v11 (dghm_inc 𝔅 ℭ⦇ArrMap⦈ ↾⇧l⇩∘ Hom 𝔅 a b)"
if "a ∈⇩∘ 𝔅⦇Obj⦈" and "b ∈⇩∘ 𝔅⦇Obj⦈" for a b
using that unfolding dghm_inc_components by simp
qed (cs_concl cs_simp: dg_cs_simps cs_intro: dg_cs_intros)+
lemmas (in subdigraph) subdg_dghm_inc_is_ft_dghm = inc.is_ft_dghm_axioms
subsubsection‹The inclusion digraph homomorphism for the opposite digraphs›
lemma (in subdigraph) subdg_dghm_inc_op_dg_is_dghm[dg_sub_cs_intros]:
"dghm_inc (op_dg 𝔅) (op_dg ℭ) : op_dg 𝔅 ↦↦⇩D⇩G⇩.⇩f⇩a⇩i⇩t⇩h⇩f⇩u⇩l⇘α⇙ op_dg ℭ"
by (intro subdigraph.subdg_dghm_inc_is_ft_dghm subdg_subdigraph_op_dg_op_dg)
lemmas [dg_sub_cs_intros] = subdigraph.subdg_dghm_inc_op_dg_is_dghm
lemma (in subdigraph) subdg_op_dg_dghm_inc[dg_op_simps]:
"op_dghm (dghm_inc 𝔅 ℭ) = dghm_inc (op_dg 𝔅) (op_dg ℭ)"
by (rule dghm_eqI, unfold dg_op_simps dghm_inc_components id_def)
(
auto
simp: subdg_dghm_inc_op_dg_is_dghm is_ft_dghmD
intro: dg_op_intros dg_cs_intros
)
lemmas [dg_op_simps] = subdigraph.subdg_op_dg_dghm_inc
subsection‹Full subdigraph›
text‹See Chapter I-3 in \cite{mac_lane_categories_2010}.›
locale fl_subdigraph = subdigraph +
assumes fl_subdg_is_fl_dghm_inc: "dghm_inc 𝔅 ℭ : 𝔅 ↦↦⇩D⇩G⇩.⇩f⇩u⇩l⇩l⇘α⇙ ℭ"
abbreviation is_fl_subdigraph ("(_/ ⊆⇩D⇩G⇩.⇩f⇩u⇩l⇩lı _)" [51, 51] 50)
where "𝔅 ⊆⇩D⇩G⇩.⇩f⇩u⇩l⇩l⇘α⇙ ℭ ≡ fl_subdigraph α 𝔅 ℭ"
sublocale fl_subdigraph ⊆ inc: is_fl_dghm α 𝔅 ℭ ‹dghm_inc 𝔅 ℭ›
by (rule fl_subdg_is_fl_dghm_inc)
text‹Rules.›
lemma (in fl_subdigraph) fl_subdigraph_axioms'[dg_cs_intros]:
assumes "α' = α" and "𝔅' = 𝔅"
shows "𝔅' ⊆⇩D⇩G⇩.⇩f⇩u⇩l⇩l⇘α'⇙ ℭ"
unfolding assms by (rule fl_subdigraph_axioms)
lemma (in fl_subdigraph) fl_subdigraph_axioms''[dg_cs_intros]:
assumes "α' = α" and "ℭ' = ℭ"
shows "𝔅 ⊆⇩D⇩G⇩.⇩f⇩u⇩l⇩l⇘α'⇙ ℭ'"
unfolding assms by (rule fl_subdigraph_axioms)
mk_ide rf fl_subdigraph_def[unfolded fl_subdigraph_axioms_def]
|intro fl_subdigraphI|
|dest fl_subdigraphD[dest]|
|elim fl_subdigraphE[elim!]|
lemmas [dg_sub_cs_intros] = fl_subdigraphD(1)
text‹Elementary properties.›
lemma (in fl_subdigraph) fl_subdg_Hom_eq:
assumes "A ∈⇩∘ 𝔅⦇Obj⦈" and "B ∈⇩∘ 𝔅⦇Obj⦈"
shows "Hom 𝔅 A B = Hom ℭ A B"
proof-
from assms have Arr_AB: "𝔅⦇Arr⦈ ∩⇩∘ Hom 𝔅 A B = Hom 𝔅 A B"
by
(
intro vsubset_antisym vsubsetI,
unfold vintersection_iff in_Hom_iff;
(elim conjE)?;
(intro conjI)?
)
(auto intro: dg_cs_intros)
from assms have A: "vid_on (𝔅⦇Obj⦈)⦇A⦈ = A" and B: "vid_on (𝔅⦇Obj⦈)⦇B⦈ = B"
by simp_all
from inc.fl_dghm_surj_on_Hom[OF assms, unfolded dghm_inc_components] show
"Hom 𝔅 A B = Hom ℭ A B"
by (auto simp: Arr_AB A B)
qed
subsection‹Wide subdigraph›
subsubsection‹Definition and elementary properties›
text‹
See \cite{noauthor_nlab_nodate}\footnote{
\url{https://ncatlab.org/nlab/show/wide+subcategory}
}).
›
locale wide_subdigraph = subdigraph +
assumes wide_subdg_Obj[dg_sub_bw_cs_intros]: "a ∈⇩∘ ℭ⦇Obj⦈ ⟹ a ∈⇩∘ 𝔅⦇Obj⦈"
abbreviation is_wide_subdigraph ("(_/ ⊆⇩D⇩G⇩.⇩w⇩i⇩d⇩eı _)" [51, 51] 50)
where "𝔅 ⊆⇩D⇩G⇩.⇩w⇩i⇩d⇩e⇘α⇙ ℭ ≡ wide_subdigraph α 𝔅 ℭ"
lemmas [dg_sub_bw_cs_intros] = wide_subdigraph.wide_subdg_Obj
text‹Rules.›
lemma (in wide_subdigraph) wide_subdigraph_axioms'[dg_cs_intros]:
assumes "α' = α" and "𝔅' = 𝔅"
shows "𝔅' ⊆⇩D⇩G⇩.⇩w⇩i⇩d⇩e⇘α'⇙ ℭ"
unfolding assms by (rule wide_subdigraph_axioms)
lemma (in wide_subdigraph) wide_subdigraph_axioms''[dg_cs_intros]:
assumes "α' = α" and "ℭ' = ℭ"
shows "𝔅 ⊆⇩D⇩G⇩.⇩w⇩i⇩d⇩e⇘α'⇙ ℭ'"
unfolding assms by (rule wide_subdigraph_axioms)
mk_ide rf wide_subdigraph_def[unfolded wide_subdigraph_axioms_def]
|intro wide_subdigraphI|
|dest wide_subdigraphD[dest]|
|elim wide_subdigraphE[elim!]|
lemmas [dg_sub_cs_intros] = wide_subdigraphD(1)
text‹Elementary properties.›
lemma (in wide_subdigraph) wide_subdg_obj_eq[dg_sub_bw_cs_simps]:
"𝔅⦇Obj⦈ = ℭ⦇Obj⦈"
using subdg_Obj_vsubset wide_subdg_Obj by auto
lemmas [dg_sub_bw_cs_simps] = wide_subdigraph.wide_subdg_obj_eq
subsubsection‹The wide subdigraph relation is a partial order›
lemma wide_subdg_refl:
assumes "digraph α 𝔄"
shows "𝔄 ⊆⇩D⇩G⇩.⇩w⇩i⇩d⇩e⇘α⇙ 𝔄"
proof-
interpret digraph α 𝔄 by (rule assms)
show ?thesis by unfold_locales simp
qed
lemma wide_subdg_trans[trans]:
assumes "𝔄 ⊆⇩D⇩G⇩.⇩w⇩i⇩d⇩e⇘α⇙ 𝔅" and "𝔅 ⊆⇩D⇩G⇩.⇩w⇩i⇩d⇩e⇘α⇙ ℭ"
shows "𝔄 ⊆⇩D⇩G⇩.⇩w⇩i⇩d⇩e⇘α⇙ ℭ"
proof-
interpret 𝔄𝔅: wide_subdigraph α 𝔄 𝔅 by (rule assms(1))
interpret 𝔅ℭ: wide_subdigraph α 𝔅 ℭ by (rule assms(2))
interpret 𝔄ℭ: subdigraph α 𝔄 ℭ
by (rule subdg_trans) (cs_concl cs_intro: dg_cs_intros)+
show ?thesis
by (cs_concl cs_intro: dg_sub_bw_cs_intros dg_cs_intros wide_subdigraphI)
qed
lemma wide_subdg_antisym:
assumes "𝔄 ⊆⇩D⇩G⇩.⇩w⇩i⇩d⇩e⇘α⇙ 𝔅" and "𝔅 ⊆⇩D⇩G⇩.⇩w⇩i⇩d⇩e⇘α⇙ 𝔄"
shows "𝔄 = 𝔅"
proof-
interpret 𝔄𝔅: wide_subdigraph α 𝔄 𝔅 by (rule assms(1))
interpret 𝔅𝔄: wide_subdigraph α 𝔅 𝔄 by (rule assms(2))
show ?thesis
by (rule subdg_antisym[OF 𝔄𝔅.subdigraph_axioms 𝔅𝔄.subdigraph_axioms])
qed
text‹\newpage›
end
Theory CZH_DG_Simple
section‹Simple digraphs›
theory CZH_DG_Simple
imports CZH_DG_DGHM
begin
subsection‹Background›
text‹
The section presents a variety of simple digraphs, such as the empty digraph ‹0›
and a digraph with one object and one arrow ‹1›. All of the entities
presented in this section are generalizations of certain simple categories,
whose definitions can be found in \cite{mac_lane_categories_2010}.
›
subsection‹Empty digraph ‹0››
subsubsection‹Definition and elementary properties›
text‹See Chapter I-2 in \cite{mac_lane_categories_2010}.›
definition dg_0 :: V
where "dg_0 = [0, 0, 0, 0]⇩∘"
text‹Components.›
lemma dg_0_components:
shows "dg_0⦇Obj⦈ = 0"
and "dg_0⦇Arr⦈ = 0"
and "dg_0⦇Dom⦈ = 0"
and "dg_0⦇Cod⦈ = 0"
unfolding dg_0_def dg_field_simps by (simp_all add: nat_omega_simps)
subsubsection‹‹0› is a digraph›
lemma (in 𝒵) digraph_dg_0: "digraph α dg_0"
proof(intro digraphI)
show "vfsequence dg_0" unfolding dg_0_def by (simp add: nat_omega_simps)
show "vcard dg_0 = 4⇩ℕ" unfolding dg_0_def by (simp add: nat_omega_simps)
qed (auto simp: dg_0_components)
subsubsection‹Arrow with a domain and a codomain›
lemma dg_0_is_arr_iff[simp]: "𝔉 : 𝔄 ↦⇘dg_0⇙ 𝔅 ⟷ False"
by (rule iffI; (elim is_arrE)?) (auto simp: dg_0_components)
subsubsection‹A digraph without objects is empty›
lemma (in digraph) dg_dg_0_if_Obj_0:
assumes "ℭ⦇Obj⦈ = 0"
shows "ℭ = dg_0"
by (rule dg_eqI[of α])
(
auto simp:
dg_cs_intros
assms
digraph_dg_0
dg_0_components
dg_Arr_vempty_if_Obj_vempty
dg_Cod_vempty_if_Arr_vempty
dg_Dom_vempty_if_Arr_vempty
)
subsection‹Empty digraph homomorphism›
subsubsection‹Definition and elementary properties›
definition dghm_0 :: "V ⇒ V"
where "dghm_0 𝔄 = [0, 0, dg_0, 𝔄]⇩∘"
text‹Components.›
lemma dghm_0_components:
shows "dghm_0 𝔄⦇ObjMap⦈ = 0"
and "dghm_0 𝔄⦇ArrMap⦈ = 0"
and "dghm_0 𝔄⦇HomDom⦈ = dg_0"
and "dghm_0 𝔄⦇HomCod⦈ = 𝔄"
unfolding dghm_0_def dghm_field_simps by (simp_all add: nat_omega_simps)
subsubsection‹Empty digraph homomorphism is a faithful digraph homomorphism›
lemma (in 𝒵) dghm_0_is_dghm:
assumes "digraph α 𝔄"
shows "dghm_0 𝔄 : dg_0 ↦↦⇩D⇩G⇩.⇩f⇩a⇩i⇩t⇩h⇩f⇩u⇩l⇘α⇙ 𝔄"
proof(rule is_ft_dghmI)
show "dghm_0 𝔄 : dg_0 ↦↦⇩D⇩G⇘α⇙ 𝔄"
proof(rule is_dghmI)
show "vfsequence (dghm_0 𝔄)" unfolding dghm_0_def by simp
show "vcard (dghm_0 𝔄) = 4⇩ℕ"
unfolding dghm_0_def by (simp add: nat_omega_simps)
qed (auto simp: assms digraph_dg_0 dghm_0_components dg_0_components)
qed (auto simp: dg_0_components dghm_0_components)
subsection‹‹10›: digraph with one object and no arrows›
subsubsection‹Definition and elementary properties›
definition dg_10 :: "V ⇒ V"
where "dg_10 𝔞 = [set {𝔞}, 0, 0, 0]⇩∘"
text‹Components.›
lemma dg_10_components:
shows "dg_10 𝔞⦇Obj⦈ = set {𝔞}"
and "dg_10 𝔞⦇Arr⦈ = 0"
and "dg_10 𝔞⦇Dom⦈ = 0"
and "dg_10 𝔞⦇Cod⦈ = 0"
unfolding dg_10_def dg_field_simps by (auto simp: nat_omega_simps)
subsubsection‹‹10› is a digraph›
lemma (in 𝒵) digraph_dg_10:
assumes "𝔞 ∈⇩∘ Vset α"
shows "digraph α (dg_10 𝔞)"
proof(intro digraphI)
show "vfsequence (dg_10 𝔞)" unfolding dg_10_def by (simp add: nat_omega_simps)
show "vcard (dg_10 𝔞) = 4⇩ℕ" unfolding dg_10_def by (simp add: nat_omega_simps)
show "(⋃⇩∘a'∈⇩∘A. ⋃⇩∘b'∈⇩∘B. Hom (dg_10 𝔞) a' b') ∈⇩∘ Vset α" for A B
proof-
have "(⋃⇩∘a'∈⇩∘A. ⋃⇩∘b'∈⇩∘B. Hom (dg_10 𝔞) a' b') ⊆⇩∘ dg_10 𝔞⦇Arr⦈" by auto
moreover have "dg_10 𝔞⦇Arr⦈ ⊆⇩∘ 0" unfolding dg_10_components by auto
ultimately show ?thesis using vempty_is_zet vsubset_in_VsetI by presburger
qed
qed (auto simp: assms dg_10_components vsubset_vsingleton_leftI)
subsubsection‹Arrow with a domain and a codomain›
lemma dg_10_is_arr_iff: "𝔉 : 𝔄 ↦⇘dg_10 𝔞⇙ 𝔅 ⟷ False"
unfolding is_arr_def dg_10_components by simp
subsection‹‹1›: digraph with one object and one arrow›
subsubsection‹Definition and elementary properties›
definition dg_1 :: "V ⇒ V ⇒ V"
where "dg_1 𝔞 𝔣 = [set {𝔞}, set {𝔣}, set {⟨𝔣, 𝔞⟩}, set {⟨𝔣, 𝔞⟩}]⇩∘"
text‹Components.›
lemma dg_1_components:
shows "dg_1 𝔞 𝔣⦇Obj⦈ = set {𝔞}"
and "dg_1 𝔞 𝔣⦇Arr⦈ = set {𝔣}"
and "dg_1 𝔞 𝔣⦇Dom⦈ = set {⟨𝔣, 𝔞⟩}"
and "dg_1 𝔞 𝔣⦇Cod⦈ = set {⟨𝔣, 𝔞⟩}"
unfolding dg_1_def dg_field_simps by (simp_all add: nat_omega_simps)
subsubsection‹‹1› is a digraph›
lemma (in 𝒵) digraph_dg_1:
assumes "𝔞 ∈⇩∘ Vset α" and "𝔣 ∈⇩∘ Vset α"
shows "digraph α (dg_1 𝔞 𝔣)"
proof(intro digraphI)
show "vfsequence (dg_1 𝔞 𝔣)" unfolding dg_1_def by (simp add: nat_omega_simps)
show "vcard (dg_1 𝔞 𝔣) = 4⇩ℕ" unfolding dg_1_def by (simp add: nat_omega_simps)
show "(⋃⇩∘a'∈⇩∘A. ⋃⇩∘b'∈⇩∘B. Hom (dg_1 𝔞 𝔣) a' b') ∈⇩∘ Vset α" for A B
proof-
have "(⋃⇩∘a'∈⇩∘A. ⋃⇩∘b'∈⇩∘B. Hom (dg_1 𝔞 𝔣) a' b') ⊆⇩∘ dg_1 𝔞 𝔣⦇Arr⦈" by auto
moreover have "dg_1 𝔞 𝔣⦇Arr⦈ ⊆⇩∘ set {𝔣}" unfolding dg_1_components by auto
moreover from assms(2) have "set {𝔣} ∈⇩∘ Vset α"
by (simp add: Limit_vsingleton_in_VsetI)
ultimately show ?thesis
unfolding dg_1_components by (auto simp: vsubset_in_VsetI)
qed
qed (auto simp: assms dg_1_components vsubset_vsingleton_leftI)
subsubsection‹Arrow with a domain and a codomain›
lemma dg_1_is_arrI:
assumes "a = 𝔞" and "b = 𝔞" and "f = 𝔣"
shows "f : a ↦⇘dg_1 𝔞 𝔣⇙ b"
using assms by (intro is_arrI) (auto simp: dg_1_components)
lemma dg_1_is_arrD:
assumes "f : a ↦⇘dg_1 𝔞 𝔣⇙ b"
shows "a = 𝔞" and "b = 𝔞" and "f = 𝔣"
using assms by (all‹elim is_arrE›) (auto simp: dg_1_components)
lemma dg_1_is_arrE:
assumes "f : a ↦⇘dg_1 𝔞 𝔣⇙ b"
obtains "a = 𝔞" and "b = 𝔞" and "f = 𝔣"
using assms by (elim is_arrE) (force simp: dg_1_components)
lemma dg_1_is_arr_iff: "f : a ↦⇘dg_1 𝔞 𝔣⇙ b ⟷ (a = 𝔞 ∧ b = 𝔞 ∧ f = 𝔣)"
by (rule iffI; (elim is_arrE)?)
(auto simp: dg_1_components intro: dg_1_is_arrI)
text‹\newpage›
end
Theory CZH_DG_GRPH
section‹‹GRPH› as a digraph›
theory CZH_DG_GRPH
imports
CZH_DG_DGHM
CZH_DG_Small_Digraph
begin
subsection‹Background›
text‹
Conventionally, ‹GRPH› defined as a category of digraphs and digraph
homomorphisms (e.g., see Chapter II-7 in \cite{mac_lane_categories_2010}).
However, there is little that can prevent one from exposing ‹GRPH›
as a digraph and provide additional structure gradually in
subsequent installments of this work. Thus, in this section, ‹α›-‹GRPH› is
defined as a digraph of digraphs and digraph homomorphisms in ‹V⇩α›.
›
named_theorems GRPH_cs_simps
named_theorems GRPH_cs_intros
subsection‹Definition and elementary properties›
definition dg_GRPH :: "V ⇒ V"
where "dg_GRPH α =
[
set {ℭ. digraph α ℭ},
all_dghms α,
(λ𝔉∈⇩∘all_dghms α. 𝔉⦇HomDom⦈),
(λ𝔉∈⇩∘all_dghms α. 𝔉⦇HomCod⦈)
]⇩∘"
text‹Components.›
lemma dg_GRPH_components:
shows "dg_GRPH α⦇Obj⦈ = set {ℭ. digraph α ℭ}"
and "dg_GRPH α⦇Arr⦈ = all_dghms α"
and "dg_GRPH α⦇Dom⦈ = (λ𝔉∈⇩∘all_dghms α. 𝔉⦇HomDom⦈)"
and "dg_GRPH α⦇Cod⦈ = (λ𝔉∈⇩∘all_dghms α. 𝔉⦇HomCod⦈)"
unfolding dg_GRPH_def dg_field_simps by (simp_all add: nat_omega_simps)
subsection‹Object›
lemma dg_GRPH_ObjI:
assumes "digraph α 𝔄"
shows "𝔄 ∈⇩∘ dg_GRPH α⦇Obj⦈"
using assms unfolding dg_GRPH_components by auto
lemma dg_GRPH_ObjD:
assumes "𝔄 ∈⇩∘ dg_GRPH α⦇Obj⦈"
shows "digraph α 𝔄"
using assms unfolding dg_GRPH_components by auto
lemma dg_GRPH_ObjE:
assumes "𝔄 ∈⇩∘ dg_GRPH α⦇Obj⦈"
obtains "digraph α 𝔄"
using assms unfolding dg_GRPH_components by auto
lemma dg_GRPH_Obj_iff[GRPH_cs_simps]:
"𝔄 ∈⇩∘ dg_GRPH α⦇Obj⦈ ⟷ digraph α 𝔄"
unfolding dg_GRPH_components by auto
subsection‹Domain›
mk_VLambda dg_GRPH_components(3)
|vsv dg_GRPH_Dom_vsv[GRPH_cs_intros]|
|vdomain dg_GRPH_Dom_vdomain[GRPH_cs_simps]|
|app dg_GRPH_Dom_app[GRPH_cs_simps]|
lemma dg_GRPH_Dom_vrange: "ℛ⇩∘ (dg_GRPH α⦇Dom⦈) ⊆⇩∘ dg_GRPH α⦇Obj⦈"
unfolding dg_GRPH_components by (rule vrange_VLambda_vsubset) auto
subsection‹Codomain›
mk_VLambda dg_GRPH_components(4)
|vsv dg_GRPH_Cod_vsv[GRPH_cs_intros]|
|vdomain dg_GRPH_Cod_vdomain[GRPH_cs_simps]|
|app dg_GRPH_Cod_app[GRPH_cs_simps]|
lemma dg_GRPH_Cod_vrange: "ℛ⇩∘ (dg_GRPH α⦇Cod⦈) ⊆⇩∘ dg_GRPH α⦇Obj⦈"
unfolding dg_GRPH_components by (rule vrange_VLambda_vsubset) auto
subsection‹‹GRPH› is a digraph›
lemma (in 𝒵) tiny_digraph_dg_GRPH:
assumes "𝒵 β" and "α ∈⇩∘ β"
shows "tiny_digraph β (dg_GRPH α)"
proof(intro tiny_digraphI)
show "vfsequence (dg_GRPH α)" unfolding dg_GRPH_def by simp
show "vcard (dg_GRPH α) = 4⇩ℕ"
unfolding dg_GRPH_def by (simp add: nat_omega_simps)
show "ℛ⇩∘ (dg_GRPH α⦇Dom⦈) ⊆⇩∘ dg_GRPH α⦇Obj⦈" by (simp add: dg_GRPH_Dom_vrange)
show "ℛ⇩∘ (dg_GRPH α⦇Cod⦈) ⊆⇩∘ dg_GRPH α⦇Obj⦈" by (simp add: dg_GRPH_Cod_vrange)
show "dg_GRPH α⦇Obj⦈ ∈⇩∘ Vset β"
unfolding dg_GRPH_components by (rule digraphs_in_Vset[OF assms])
show "dg_GRPH α⦇Arr⦈ ∈⇩∘ Vset β"
unfolding dg_GRPH_components by (rule all_dghms_in_Vset[OF assms])
qed (auto simp: assms dg_GRPH_components)
subsection‹Arrow with a domain and a codomain›
lemma dg_GRPH_is_arrI:
assumes "𝔉 : 𝔄 ↦↦⇩D⇩G⇘α⇙ 𝔅"
shows "𝔉 : 𝔄 ↦⇘dg_GRPH α⇙ 𝔅"
proof(intro is_arrI; unfold dg_GRPH_components)
from assms show "𝔉 ∈⇩∘ all_dghms α" by auto
with assms show
"(λ𝔉∈⇩∘all_dghms α. 𝔉⦇HomDom⦈)⦇𝔉⦈ = 𝔄"
"(λ𝔉∈⇩∘all_dghms α. 𝔉⦇HomCod⦈)⦇𝔉⦈ = 𝔅"
by (auto simp: GRPH_cs_simps)
qed
lemma dg_GRPH_is_arrD:
assumes "𝔉 : 𝔄 ↦⇘dg_GRPH α⇙ 𝔅"
shows "𝔉 : 𝔄 ↦↦⇩D⇩G⇘α⇙ 𝔅"
using assms by (elim is_arrE) (auto simp: dg_GRPH_components)
lemma dg_GRPH_is_arrE:
assumes "𝔉 : 𝔄 ↦⇘dg_GRPH α⇙ 𝔅"
obtains "𝔉 : 𝔄 ↦↦⇩D⇩G⇘α⇙ 𝔅"
using assms by (simp add: dg_GRPH_is_arrD)
lemma dg_GRPH_is_arr_iff[GRPH_cs_simps]:
"𝔉 : 𝔄 ↦⇘dg_GRPH α⇙ 𝔅 ⟷ 𝔉 : 𝔄 ↦↦⇩D⇩G⇘α⇙ 𝔅"
by (auto intro: dg_GRPH_is_arrI dest: dg_GRPH_is_arrD)
text‹\newpage›
end
Theory CZH_DG_Rel
section‹‹Rel› as a digraph›
theory CZH_DG_Rel
imports CZH_DG_Small_DGHM
begin
subsection‹Background›
text‹
‹Rel› is usually defined as a category of sets and binary relations
(e.g., see Chapter I-7 in \cite{mac_lane_categories_2010}). However, there
is little that can prevent one from exposing ‹Rel› as a digraph and
provide additional structure gradually in subsequent installments of this
work. Thus, in this section, ‹α›-‹Rel› is defined as a digraph of sets
and binary relations in ‹V⇩α›.
›
named_theorems dg_Rel_shared_cs_simps
named_theorems dg_Rel_shared_cs_intros
named_theorems dg_Rel_cs_simps
named_theorems dg_Rel_cs_intros
subsection‹Canonical arrow for \<^typ>‹V››
named_theorems arr_field_simps
definition ArrVal :: V where [arr_field_simps]: "ArrVal = 0"
definition ArrDom :: V where [arr_field_simps]: "ArrDom = 1⇩ℕ"
definition ArrCod :: V where [arr_field_simps]: "ArrCod = 2⇩ℕ"
lemma ArrVal_eq_helper:
assumes "f = g"
shows "f⦇ArrVal⦈⦇a⦈ = g⦇ArrVal⦈⦇a⦈"
using assms by simp
subsection‹Arrow for ‹Rel››
subsubsection‹Definition and elementary properties›
locale arr_Rel = 𝒵 α + vfsequence T + ArrVal: vbrelation ‹T⦇ArrVal⦈› for α T +
assumes arr_Rel_length[dg_Rel_shared_cs_simps, dg_Rel_cs_simps]:
"vcard T = 3⇩ℕ"
and arr_Rel_ArrVal_vdomain: "𝒟⇩∘ (T⦇ArrVal⦈) ⊆⇩∘ T⦇ArrDom⦈"
and arr_Rel_ArrVal_vrange: "ℛ⇩∘ (T⦇ArrVal⦈) ⊆⇩∘ T⦇ArrCod⦈"
and arr_Rel_ArrDom_in_Vset: "T⦇ArrDom⦈ ∈⇩∘ Vset α"
and arr_Rel_ArrCod_in_Vset: "T⦇ArrCod⦈ ∈⇩∘ Vset α"
lemmas [dg_Rel_cs_simps] = arr_Rel.arr_Rel_length
text‹Components.›
lemma arr_Rel_components[dg_Rel_shared_cs_simps, dg_Rel_cs_simps]:
shows "[f, A, B]⇩∘⦇ArrVal⦈ = f"
and "[f, A, B]⇩∘⦇ArrDom⦈ = A"
and "[f, A, B]⇩∘⦇ArrCod⦈ = B"
unfolding arr_field_simps by (simp_all add: nat_omega_simps)
text‹Rules.›
mk_ide rf arr_Rel_def[unfolded arr_Rel_axioms_def]
|intro arr_RelI|
|dest arr_RelD[dest]|
|elim arr_RelE[elim!]|
lemma (in 𝒵) arr_Rel_vfsequenceI:
assumes "vbrelation r"
and "𝒟⇩∘ r ⊆⇩∘ a"
and "ℛ⇩∘ r ⊆⇩∘ b"
and "a ∈⇩∘ Vset α"
and "b ∈⇩∘ Vset α"
shows "arr_Rel α [r, a, b]⇩∘"
by (intro arr_RelI)
(insert assms, auto simp: nat_omega_simps arr_Rel_components)
text‹Elementary properties.›
lemma arr_Rel_eqI:
assumes "arr_Rel α S"
and "arr_Rel α T"
and "S⦇ArrVal⦈ = T⦇ArrVal⦈"
and "S⦇ArrDom⦈ = T⦇ArrDom⦈"
and "S⦇ArrCod⦈ = T⦇ArrCod⦈"
shows "S = T"
proof-
interpret S: arr_Rel α S by (rule assms(1))
interpret T: arr_Rel α T by (rule assms(2))
show ?thesis
proof(rule vsv_eqI)
show "𝒟⇩∘ S = 𝒟⇩∘ T"
by (simp add: S.vfsequence_vdomain T.vfsequence_vdomain dg_Rel_cs_simps)
have dom_lhs: "𝒟⇩∘ S = 3⇩ℕ"
by (simp add: S.vfsequence_vdomain dg_Rel_cs_simps)
show "a ∈⇩∘ 𝒟⇩∘ S ⟹ S⦇a⦈ = T⦇a⦈" for a
by (unfold dom_lhs, elim_in_numeral, insert assms)
(auto simp: arr_field_simps)
qed auto
qed
lemma (in arr_Rel) arr_Rel_def: "T = [T⦇ArrVal⦈, T⦇ArrDom⦈, T⦇ArrCod⦈]⇩∘"
proof(rule vsv_eqI)
have dom_lhs: "𝒟⇩∘ T = 3⇩ℕ" by (simp add: vfsequence_vdomain dg_Rel_cs_simps)
have dom_rhs: "𝒟⇩∘ [T⦇ArrVal⦈, T⦇ArrDom⦈, T⦇ArrCod⦈]⇩∘ = 3⇩ℕ"
by (simp add: nat_omega_simps)
then show "𝒟⇩∘ T = 𝒟⇩∘ [T⦇ArrVal⦈, T⦇ArrDom⦈, T⦇ArrCod⦈]⇩∘"
unfolding dom_lhs dom_rhs by simp
show "a ∈⇩∘ 𝒟⇩∘ T ⟹ T⦇a⦈ = [T⦇ArrVal⦈, T⦇ArrDom⦈, T⦇ArrCod⦈]⇩∘⦇a⦈" for a
unfolding dom_lhs
by elim_in_numeral (simp_all add: arr_field_simps nat_omega_simps)
qed (auto simp: vsv_axioms)
text‹Size.›
lemma (in arr_Rel) arr_Rel_ArrVal_in_Vset: "T⦇ArrVal⦈ ∈⇩∘ Vset α"
proof-
from arr_Rel_ArrVal_vdomain arr_Rel_ArrDom_in_Vset have
"𝒟⇩∘ (T⦇ArrVal⦈) ∈⇩∘ Vset α"
by auto
moreover from arr_Rel_ArrVal_vrange arr_Rel_ArrCod_in_Vset have
"ℛ⇩∘ (T⦇ArrVal⦈) ∈⇩∘ Vset α"
by auto
ultimately show "T⦇ArrVal⦈ ∈⇩∘ Vset α"
by (simp add: ArrVal.vbrelation_Limit_in_VsetI)
qed
lemma (in arr_Rel) arr_Rel_in_Vset: "T ∈⇩∘ Vset α"
proof-
note [dg_Rel_cs_intros] =
arr_Rel_ArrVal_in_Vset arr_Rel_ArrDom_in_Vset arr_Rel_ArrCod_in_Vset
show ?thesis
by (subst arr_Rel_def)
(cs_concl cs_intro: dg_Rel_cs_intros V_cs_intros)
qed
lemma small_arr_Rel[simp]: "small {T. arr_Rel α T}"
by (rule down[of _ ‹Vset α›]) (auto intro!: arr_Rel.arr_Rel_in_Vset)
text‹Other elementary properties.›
lemma set_Collect_arr_Rel[simp]:
"x ∈⇩∘ set (Collect (arr_Rel α)) ⟷ arr_Rel α x"
by auto
lemma (in arr_Rel) arr_Rel_ArrVal_vsubset_ArrDom_ArrCod:
"T⦇ArrVal⦈ ⊆⇩∘ T⦇ArrDom⦈ ×⇩∘ T⦇ArrCod⦈"
proof
fix ab assume "ab ∈⇩∘ T⦇ArrVal⦈"
then obtain a b where "ab = ⟨a, b⟩"
and "a ∈⇩∘ 𝒟⇩∘ (T⦇ArrVal⦈)"
and "b ∈⇩∘ ℛ⇩∘ (T⦇ArrVal⦈)"
by (blast elim: ArrVal.vbrelation_vinE)
with arr_Rel_ArrVal_vdomain arr_Rel_ArrVal_vrange show
"ab ∈⇩∘ T⦇ArrDom⦈ ×⇩∘ T⦇ArrCod⦈"
by auto
qed
subsubsection‹Composition›
text‹See Chapter I-7 in \cite{mac_lane_categories_2010}.›
definition comp_Rel :: "V ⇒ V ⇒ V" (infixl ‹∘⇩R⇩e⇩l› 55)
where "comp_Rel S T = [S⦇ArrVal⦈ ∘⇩∘ T⦇ArrVal⦈, T⦇ArrDom⦈, S⦇ArrCod⦈]⇩∘"
text‹Components.›
lemma comp_Rel_components:
shows "(S ∘⇩R⇩e⇩l T)⦇ArrVal⦈ = S⦇ArrVal⦈ ∘⇩∘ T⦇ArrVal⦈"
and [dg_Rel_shared_cs_simps, dg_Rel_cs_simps]:
"(S ∘⇩R⇩e⇩l T)⦇ArrDom⦈ = T⦇ArrDom⦈"
and [dg_Rel_shared_cs_simps, dg_Rel_cs_simps]:
"(S ∘⇩R⇩e⇩l T)⦇ArrCod⦈ = S⦇ArrCod⦈"
unfolding comp_Rel_def arr_field_simps by (simp_all add: nat_omega_simps)
text‹Elementary properties.›
lemma comp_Rel_vsv[dg_Rel_shared_cs_intros, dg_Rel_cs_intros]:
"vsv (S ∘⇩R⇩e⇩l T)"
unfolding comp_Rel_def by auto
lemma arr_Rel_comp_Rel[dg_Rel_cs_intros]:
assumes "arr_Rel α S" and "arr_Rel α T"
shows "arr_Rel α (S ∘⇩R⇩e⇩l T)"
proof-
interpret S: arr_Rel α S by (rule assms(1))
interpret T: arr_Rel α T by (rule assms(2))
show ?thesis
proof(intro arr_RelI)
show "vfsequence (S ∘⇩R⇩e⇩l T)" unfolding comp_Rel_def by simp
show "vcard (S ∘⇩R⇩e⇩l T) = 3⇩ℕ"
unfolding comp_Rel_def by (simp add: nat_omega_simps)
from T.arr_Rel_ArrVal_vdomain show
"𝒟⇩∘ ((S ∘⇩R⇩e⇩l T)⦇ArrVal⦈) ⊆⇩∘ (S ∘⇩R⇩e⇩l T)⦇ArrDom⦈"
unfolding comp_Rel_components by auto
show "ℛ⇩∘ ((S ∘⇩R⇩e⇩l T)⦇ArrVal⦈) ⊆⇩∘ (S ∘⇩R⇩e⇩l T)⦇ArrCod⦈"
unfolding comp_Rel_components
proof(intro vsubsetI)
fix z assume "z ∈⇩∘ ℛ⇩∘ (S⦇ArrVal⦈ ∘⇩∘ T⦇ArrVal⦈)"
then obtain x y where "⟨y, z⟩ ∈⇩∘ S⦇ArrVal⦈" and "⟨x, y⟩ ∈⇩∘ T⦇ArrVal⦈"
by (meson vcomp_obtain_middle vrange_iff_vdomain)
with S.arr_Rel_ArrVal_vrange show "z ∈⇩∘ S⦇ArrCod⦈" by auto
qed
qed
(
auto simp:
comp_Rel_components T.arr_Rel_ArrDom_in_Vset S.arr_Rel_ArrCod_in_Vset
)
qed
lemma arr_Rel_comp_Rel_assoc[dg_Rel_shared_cs_simps, dg_Rel_cs_simps]:
"(H ∘⇩R⇩e⇩l G) ∘⇩R⇩e⇩l F = H ∘⇩R⇩e⇩l (G ∘⇩R⇩e⇩l F)"
by (simp add: comp_Rel_def vcomp_assoc arr_field_simps nat_omega_simps)
subsubsection‹Inclusion arrow›
text‹
The definition of the inclusion arrow is based on the concept of the
inclusion map, e.g., see \cite{noauthor_wikipedia_2001}\footnote{
\url{https://en.wikipedia.org/wiki/Inclusion_map}
}›
definition "incl_Rel A B = [vid_on A, A, B]⇩∘"
text‹Components.›
lemma incl_Rel_components:
shows "incl_Rel A B⦇ArrVal⦈ = vid_on A"
and [dg_Rel_shared_cs_simps, dg_Rel_cs_simps]: "incl_Rel A B⦇ArrDom⦈ = A"
and [dg_Rel_shared_cs_simps, dg_Rel_cs_simps]: "incl_Rel A B⦇ArrCod⦈ = B"
unfolding incl_Rel_def arr_field_simps by (simp_all add: nat_omega_simps)
text‹Arrow value.›
lemma incl_Rel_ArrVal_vsv[dg_Rel_shared_cs_intros, dg_Rel_cs_intros]:
"vsv (incl_Rel A B⦇ArrVal⦈)"
unfolding incl_Rel_components by simp
lemma incl_Rel_ArrVal_vdomain[dg_Rel_shared_cs_simps, dg_Rel_cs_simps]:
"𝒟⇩∘ (incl_Rel A B⦇ArrVal⦈) = A"
unfolding incl_Rel_components by simp
lemma incl_Rel_ArrVal_app[dg_Rel_shared_cs_simps, dg_Rel_cs_simps]:
assumes "a ∈⇩∘ A"
shows "incl_Rel A B⦇ArrVal⦈⦇a⦈ = a"
using assms unfolding incl_Rel_components by simp
text‹Elementary properties.›
lemma incl_Rel_vfsequence[dg_Rel_shared_cs_intros, dg_Rel_cs_intros]:
"vfsequence (incl_Rel A B)"
unfolding incl_Rel_def by simp
lemma incl_Rel_vcard[dg_Rel_shared_cs_simps, dg_Rel_cs_simps]:
"vcard (incl_Rel A B) = 3⇩ℕ"
unfolding incl_Rel_def incl_Rel_def by (simp add: nat_omega_simps)
lemma (in 𝒵) arr_Rel_incl_RelI:
assumes "A ∈⇩∘ Vset α" and "B ∈⇩∘ Vset α" and "A ⊆⇩∘ B"
shows "arr_Rel α (incl_Rel A B)"
proof(intro arr_RelI)
show "vfsequence (incl_Rel A B)" unfolding incl_Rel_def by simp
show "vcard (incl_Rel A B) = 3⇩ℕ"
unfolding incl_Rel_def by (simp add: nat_omega_simps)
qed (auto simp: incl_Rel_components assms)
subsubsection‹Identity›
text‹See Chapter I-7 in \cite{mac_lane_categories_2010}.›
definition id_Rel :: "V ⇒ V"
where "id_Rel A = incl_Rel A A"
text‹Components.›
lemma id_Rel_components:
shows "id_Rel A⦇ArrVal⦈ = vid_on A"
and [dg_Rel_shared_cs_simps, dg_Rel_cs_simps]: "id_Rel A⦇ArrDom⦈ = A"
and [dg_Rel_shared_cs_simps, dg_Rel_cs_simps]: "id_Rel A⦇ArrCod⦈ = A"
unfolding id_Rel_def incl_Rel_components by simp_all
text‹Elementary properties.›
lemma id_Rel_vfsequence[dg_Rel_shared_cs_intros, dg_Rel_cs_intros]:
"vfsequence (id_Rel A)"
unfolding id_Rel_def by (simp add: dg_Rel_cs_intros)
lemma id_Rel_vcard[dg_Rel_shared_cs_simps, dg_Rel_cs_simps]:
"vcard (id_Rel A) = 3⇩ℕ"
unfolding id_Rel_def by (simp add: dg_Rel_cs_simps)
lemma (in 𝒵) arr_Rel_id_RelI:
assumes "A ∈⇩∘ Vset α"
shows "arr_Rel α (id_Rel A)"
by (intro arr_RelI)
(auto simp: id_Rel_components(1) assms dg_Rel_cs_intros dg_Rel_cs_simps)
lemma id_Rel_ArrVal_app[dg_Rel_shared_cs_simps, dg_Rel_cs_simps]:
assumes "a ∈⇩∘ A"
shows "id_Rel A⦇ArrVal⦈⦇a⦈ = a"
using assms unfolding id_Rel_components by simp
lemma arr_Rel_comp_Rel_id_Rel_left[dg_Rel_cs_simps]:
assumes "arr_Rel α F" and "F⦇ArrCod⦈ = A"
shows "id_Rel A ∘⇩R⇩e⇩l F = F"
proof(rule arr_Rel_eqI [of α])
interpret F: arr_Rel α F by (rule assms(1))
from assms(2) have "A ∈⇩∘ Vset α" by (auto intro: F.arr_Rel_ArrCod_in_Vset)
with assms(1) show "arr_Rel α (id_Rel A ∘⇩R⇩e⇩l F)"
by (blast intro: F.arr_Rel_id_RelI intro!: arr_Rel_comp_Rel)
from assms(2) F.arr_Rel_ArrVal_vrange show
"(id_Rel A ∘⇩R⇩e⇩l F)⦇ArrVal⦈ = F⦇ArrVal⦈"
unfolding comp_Rel_components id_Rel_components by auto
qed
(
use assms(2) in
‹auto simp: assms(1) comp_Rel_components id_Rel_components›
)
lemma arr_Rel_comp_Rel_id_Rel_right[dg_Rel_cs_simps]:
assumes "arr_Rel α F" and "F⦇ArrDom⦈ = A"
shows "F ∘⇩R⇩e⇩l id_Rel A = F"
proof(rule arr_Rel_eqI[of α])
interpret F: arr_Rel α F by (rule assms(1))
from assms(2) have "A ∈⇩∘ Vset α" by (auto intro: F.arr_Rel_ArrDom_in_Vset)
with assms(1) show "arr_Rel α (F ∘⇩R⇩e⇩l id_Rel A)"
by (blast intro: F.arr_Rel_id_RelI intro!: arr_Rel_comp_Rel)
show "arr_Rel α F" by (simp add: assms(1))
from assms(2) F.arr_Rel_ArrVal_vdomain show
"(F ∘⇩R⇩e⇩l id_Rel A)⦇ArrVal⦈ = F⦇ArrVal⦈"
unfolding comp_Rel_components id_Rel_components by auto
qed (use assms(2) in ‹auto simp: comp_Rel_components id_Rel_components›)
subsubsection‹Converse›
text‹
As mentioned in Chapter I-7 in \cite{mac_lane_categories_2010}, the
category ‹Rel› is usually equipped with an additional structure that is
the operation of taking a converse of a relation.
The operation is meant to be used almost exclusively as part of
the dagger functor for ‹Rel›.
›
definition converse_Rel :: "V ⇒ V" ("(_¯⇩R⇩e⇩l)" [1000] 999)
where "converse_Rel T = [(T⦇ArrVal⦈)¯⇩∘, T⦇ArrCod⦈, T⦇ArrDom⦈]⇩∘"
lemma converse_Rel_components:
shows "T¯⇩R⇩e⇩l⦇ArrVal⦈ = (T⦇ArrVal⦈)¯⇩∘"
and [dg_Rel_shared_cs_simps, dg_Rel_cs_simps]: "T¯⇩R⇩e⇩l⦇ArrDom⦈ = T⦇ArrCod⦈"
and [dg_Rel_shared_cs_simps, dg_Rel_cs_simps]: "T¯⇩R⇩e⇩l⦇ArrCod⦈ = T⦇ArrDom⦈"
unfolding converse_Rel_def arr_field_simps by (simp_all add: nat_omega_simps)
text‹Elementary properties.›
lemma (in arr_Rel) arr_Rel_converse_Rel: "arr_Rel α (T¯⇩R⇩e⇩l)"
proof(rule arr_RelI, unfold converse_Rel_components)
show "vfsequence (T¯⇩R⇩e⇩l)" unfolding converse_Rel_def by simp
show "vcard (T¯⇩R⇩e⇩l) = 3⇩ℕ"
unfolding converse_Rel_def by (simp add: nat_omega_simps)
qed
(
auto simp:
converse_Rel_components(1)
arr_Rel_ArrDom_in_Vset
arr_Rel_ArrCod_in_Vset
arr_Rel_ArrVal_vdomain
arr_Rel_ArrVal_vrange
)
lemmas [dg_Rel_cs_intros] =
arr_Rel.arr_Rel_converse_Rel
lemma (in arr_Rel)
arr_Rel_converse_Rel_converse_Rel[dg_Rel_shared_cs_simps, dg_Rel_cs_simps]:
"(T¯⇩R⇩e⇩l)¯⇩R⇩e⇩l = T"
proof(rule arr_Rel_eqI)
from arr_Rel_axioms show "arr_Rel α ((T¯⇩R⇩e⇩l)¯⇩R⇩e⇩l)"
by (cs_intro_step dg_Rel_cs_intros)+
qed (simp_all add: arr_Rel_axioms converse_Rel_components)
lemmas [dg_Rel_cs_simps] =
arr_Rel.arr_Rel_converse_Rel_converse_Rel
lemma arr_Rel_converse_Rel_eq_iff[dg_Rel_cs_simps]:
assumes "arr_Rel α F" and "arr_Rel α G"
shows "F¯⇩R⇩e⇩l = G¯⇩R⇩e⇩l ⟷ F = G"
proof(rule iffI)
show "F¯⇩R⇩e⇩l = G¯⇩R⇩e⇩l ⟹ F = G"
by (metis arr_Rel.arr_Rel_converse_Rel_converse_Rel assms)
qed simp
lemma arr_Rel_converse_Rel_comp_Rel[dg_Rel_cs_simps]:
assumes "arr_Rel α G" and "arr_Rel α F"
shows "(F ∘⇩R⇩e⇩l G)¯⇩R⇩e⇩l = G¯⇩R⇩e⇩l ∘⇩R⇩e⇩l F¯⇩R⇩e⇩l"
proof(rule arr_Rel_eqI, unfold converse_Rel_components comp_Rel_components)
from assms show "arr_Rel α (G¯⇩R⇩e⇩l ∘⇩R⇩e⇩l F¯⇩R⇩e⇩l)"
by (cs_concl cs_intro: dg_Rel_cs_intros)
from assms show "arr_Rel α ((F ∘⇩R⇩e⇩l G)¯⇩R⇩e⇩l)"
by (cs_intro_step dg_Rel_cs_intros)+
qed (simp_all add: vconverse_vcomp)
lemma (in 𝒵) arr_Rel_converse_Rel_id_Rel:
assumes "c ∈⇩∘ Vset α"
shows "arr_Rel α ((id_Rel c)¯⇩R⇩e⇩l)"
using assms 𝒵_axioms
by (cs_concl cs_intro: dg_Rel_cs_intros arr_Rel_id_RelI)+
lemma (in 𝒵) arr_Rel_converse_Rel_id_Rel_eq_id_Rel[
dg_Rel_shared_cs_simps, dg_Rel_cs_simps
]:
assumes "c ∈⇩∘ Vset α"
shows "(id_Rel c)¯⇩R⇩e⇩l = id_Rel c"
by (rule arr_Rel_eqI[of α], unfold converse_Rel_components id_Rel_components)
(simp_all add: assms arr_Rel_id_RelI arr_Rel_converse_Rel_id_Rel)
lemmas [dg_Rel_shared_cs_simps, dg_Rel_cs_simps] =
𝒵.arr_Rel_converse_Rel_id_Rel_eq_id_Rel
lemma arr_Rel_comp_Rel_converse_Rel_left_if_v11[dg_Rel_cs_simps]:
assumes "arr_Rel α T"
and "𝒟⇩∘ (T⦇ArrVal⦈) = A"
and "T⦇ArrDom⦈ = A"
and "v11 (T⦇ArrVal⦈)"
and "A ∈⇩∘ Vset α"
shows "T¯⇩R⇩e⇩l ∘⇩R⇩e⇩l T = id_Rel A"
proof-
interpret T: arr_Rel α T by (rule assms(1))
interpret v11: v11 ‹T⦇ArrVal⦈› by (rule assms(4))
show ?thesis
by (rule arr_Rel_eqI[of α])
(
auto simp:
converse_Rel_components
comp_Rel_components
id_Rel_components
assms(1,3,5)
arr_Rel.arr_Rel_converse_Rel
arr_Rel_comp_Rel
T.arr_Rel_id_RelI
v11.v11_vcomp_vconverse[unfolded assms(2)]
)
qed
lemma arr_Rel_comp_Rel_converse_Rel_right_if_v11[dg_Rel_cs_simps]:
assumes "arr_Rel α T"
and "ℛ⇩∘ (T⦇ArrVal⦈) = A"
and "T⦇ArrCod⦈ = A"
and "v11 (T⦇ArrVal⦈)"
and "A ∈⇩∘ Vset α"
shows "T ∘⇩R⇩e⇩l T¯⇩R⇩e⇩l = id_Rel A"
proof-
interpret T: arr_Rel α T by (rule assms(1))
interpret v11: v11 ‹T⦇ArrVal⦈› by (rule assms(4))
show ?thesis
by (rule arr_Rel_eqI[of α])
(
auto simp:
assms(1,3,5)
comp_Rel_components
converse_Rel_components
id_Rel_components
v11.v11_vcomp_vconverse'[unfolded assms(2)]
T.arr_Rel_id_RelI
arr_Rel.arr_Rel_converse_Rel
arr_Rel_comp_Rel
)
qed
subsection‹‹Rel› as a digraph›
subsubsection‹Definition and elementary properties›
definition dg_Rel :: "V ⇒ V"
where "dg_Rel α =
[
Vset α,
set {T. arr_Rel α T},
(λT∈⇩∘set {T. arr_Rel α T}. T⦇ArrDom⦈),
(λT∈⇩∘set {T. arr_Rel α T}. T⦇ArrCod⦈)
]⇩∘"
text‹Components.›
lemma dg_Rel_components:
shows "dg_Rel α⦇Obj⦈ = Vset α"
and "dg_Rel α⦇Arr⦈ = set {T. arr_Rel α T}"
and "dg_Rel α⦇Dom⦈ = (λT∈⇩∘set {T. arr_Rel α T}. T⦇ArrDom⦈)"
and "dg_Rel α⦇Cod⦈ = (λT∈⇩∘set {T. arr_Rel α T}. T⦇ArrCod⦈)"
unfolding dg_Rel_def dg_field_simps by (simp_all add: nat_omega_simps)
subsubsection‹Object›
lemma dg_Rel_Obj_iff: "x ∈⇩∘ dg_Rel α⦇Obj⦈ ⟷ x ∈⇩∘ Vset α"
unfolding dg_Rel_components by auto
subsubsection‹Arrow›
lemma dg_Rel_Arr_iff[dg_Rel_cs_simps]: "x ∈⇩∘ dg_Rel α⦇Arr⦈ ⟷ arr_Rel α x"
unfolding dg_Rel_components by auto
subsubsection‹Domain›
mk_VLambda dg_Rel_components(3)
|vsv dg_Rel_Dom_vsv[dg_Rel_cs_intros]|
|vdomain dg_Rel_Dom_vdomain[dg_Rel_cs_simps]|
|app dg_Rel_Dom_app[unfolded set_Collect_arr_Rel, dg_Rel_cs_simps]|
lemma dg_Rel_Dom_vrange: "ℛ⇩∘ (dg_Rel α⦇Dom⦈) ⊆⇩∘ dg_Rel α⦇Obj⦈"
unfolding dg_Rel_components
by (rule vrange_VLambda_vsubset, unfold set_Collect_arr_Rel) auto
subsubsection‹Codomain›
mk_VLambda dg_Rel_components(4)
|vsv dg_Rel_Cod_vsv[dg_Rel_cs_intros]|
|vdomain dg_Rel_Cod_vdomain[dg_Rel_cs_simps]|
|app dg_Rel_Cod_app[unfolded set_Collect_arr_Rel, dg_Rel_cs_simps]|
lemma dg_Rel_Cod_vrange: "ℛ⇩∘ (dg_Rel α⦇Cod⦈) ⊆⇩∘ dg_Rel α⦇Obj⦈"
unfolding dg_Rel_components
by (rule vrange_VLambda_vsubset, unfold set_Collect_arr_Rel) auto
subsubsection‹Arrow with a domain and a codomain›
text‹Rules.›
lemma dg_Rel_is_arrI[dg_Rel_cs_intros]:
assumes "arr_Rel α S" and "S⦇ArrDom⦈ = A" and "S⦇ArrCod⦈ = B"
shows "S : A ↦⇘dg_Rel α⇙ B"
using assms by (intro is_arrI, unfold dg_Rel_components) simp_all
lemma dg_Rel_is_arrD:
assumes "S : A ↦⇘dg_Rel α⇙ B"
shows "arr_Rel α S"
and [dg_cs_simps]: "S⦇ArrDom⦈ = A"
and [dg_cs_simps]: "S⦇ArrCod⦈ = B"
using is_arrD[OF assms] unfolding dg_Rel_components by simp_all
lemma dg_Rel_is_arrE:
assumes "S : A ↦⇘dg_Rel α⇙ B"
obtains "arr_Rel α S" and "S⦇ArrDom⦈ = A" and "S⦇ArrCod⦈ = B"
using is_arrD[OF assms] unfolding dg_Rel_components by simp_all
text‹Elementary properties.›
lemma (in 𝒵) dg_Rel_incl_Rel_is_arr:
assumes "A ∈⇩∘ Vset α" and "B ∈⇩∘ Vset α" and "A ⊆⇩∘ B"
shows "incl_Rel A B : A ↦⇘dg_Rel α⇙ B"
proof(rule dg_Rel_is_arrI)
show "arr_Rel α (incl_Rel A B)" by (intro arr_Rel_incl_RelI assms)
qed (simp_all add: incl_Rel_components)
lemma (in 𝒵) dg_Rel_incl_Rel_is_arr'[dg_Rel_cs_intros]:
assumes "A ∈⇩∘ Vset α"
and "B ∈⇩∘ Vset α"
and "A ⊆⇩∘ B"
and "A' = A"
and "B' = B"
shows "incl_Rel A B : A' ↦⇘dg_Rel α⇙ B'"
using assms(1-3) unfolding assms(4,5) by (rule dg_Rel_incl_Rel_is_arr)
lemmas [dg_Rel_cs_intros] = 𝒵.dg_Rel_incl_Rel_is_arr'
subsubsection‹‹Rel› is a digraph›
lemma (in 𝒵) dg_Rel_Hom_vifunion_in_Vset:
assumes "X ∈⇩∘ Vset α" and "Y ∈⇩∘ Vset α"
shows "(⋃⇩∘A∈⇩∘X. ⋃⇩∘B∈⇩∘Y. Hom (dg_Rel α) A B) ∈⇩∘ Vset α"
proof-
define Q where
"Q i = (if i = 0 then VPow (⋃⇩∘X ×⇩∘ ⋃⇩∘Y) else if i = 1⇩ℕ then X else Y)"
for i
have
"{[r, A, B]⇩∘ |r A B. r ⊆⇩∘ ⋃⇩∘X ×⇩∘ ⋃⇩∘Y ∧ A ∈⇩∘ X ∧ B ∈⇩∘ Y} ⊆
elts (∏⇩∘i∈⇩∘ set {0, 1⇩ℕ, 2⇩ℕ}. Q i)"
proof(intro subsetI, unfold mem_Collect_eq, elim exE conjE)
fix F r A B assume prems:
"F = [r, A, B]⇩∘"
"r ⊆⇩∘ ⋃⇩∘X ×⇩∘ ⋃⇩∘Y"
"A ∈⇩∘ X"
"B ∈⇩∘ Y"
show "F ∈⇩∘ (∏⇩∘i∈⇩∘ set {0, 1⇩ℕ, 2⇩ℕ}. Q i)"
proof(intro vproductI, unfold Ball_def; (intro allI impI)?)
show "𝒟⇩∘ F = set {0, 1⇩ℕ, 2⇩ℕ}"
by (simp add: three prems(1) nat_omega_simps)
fix i assume "i ∈⇩∘ set {0, 1⇩ℕ, 2⇩ℕ}"
then consider ‹i = 0› | ‹i = 1⇩ℕ› | ‹i = 2⇩ℕ› by auto
then show "F⦇i⦈ ∈⇩∘ Q i" by cases (auto simp: Q_def prems nat_omega_simps)
qed (auto simp: prems(1))
qed
moreover then have small[simp]:
"small {[r, A, B]⇩∘ | r A B. r ⊆⇩∘⋃⇩∘X ×⇩∘ ⋃⇩∘Y ∧ A ∈⇩∘ X ∧ B ∈⇩∘ Y}"
by (rule down)
ultimately have
"set {[r, A, B]⇩∘ |r A B. r ⊆⇩∘ ⋃⇩∘X ×⇩∘ ⋃⇩∘Y ∧ A ∈⇩∘ X ∧ B ∈⇩∘ Y} ⊆⇩∘
(∏⇩∘i∈⇩∘ set {0, 1⇩ℕ, 2⇩ℕ}. Q i)"
by auto
moreover have "(∏⇩∘i∈⇩∘ set {0, 1⇩ℕ, 2⇩ℕ}. Q i) ∈⇩∘ Vset α"
proof(rule Limit_vproduct_in_VsetI)
show "set {0, 1⇩ℕ, 2⇩ℕ} ∈⇩∘ Vset α"
by (auto simp: three[symmetric] intro!: Axiom_of_Infinity)
from assms(1,2) have "VPow (⋃⇩∘X ×⇩∘ ⋃⇩∘Y) ∈⇩∘ Vset α"
by (intro Limit_VPow_in_VsetI Limit_vtimes_in_VsetI) auto
then show "Q i ∈⇩∘ Vset α" if "i ∈⇩∘ set {0, 1⇩ℕ, 2⇩ℕ}" for i
using that assms(1,2) unfolding Q_def by (auto simp: nat_omega_simps)
qed auto
moreover have
"(⋃⇩∘A∈⇩∘X. ⋃⇩∘B∈⇩∘Y. Hom (dg_Rel α) A B) ⊆⇩∘
set {[r, A, B]⇩∘ | r A B. r ⊆⇩∘⋃⇩∘X ×⇩∘ ⋃⇩∘Y ∧ A ∈⇩∘ X ∧ B ∈⇩∘ Y}"
proof(rule vsubsetI)
fix F assume prems: "F ∈⇩∘ (⋃⇩∘A∈⇩∘X. ⋃⇩∘B∈⇩∘Y. Hom (dg_Rel α) A B)"
then obtain A where A: "A ∈⇩∘ X" and F_b: "F ∈⇩∘ (⋃⇩∘B∈⇩∘Y. Hom (dg_Rel α) A B)"
unfolding vifunion_iff by auto
then obtain B where B: "B ∈⇩∘ Y" and F_fba: "F ∈⇩∘ Hom (dg_Rel α) A B"
by fastforce
then have "F : A ↦⇘dg_Rel α⇙ B" by simp
note F = dg_Rel_is_arrD[OF this]
interpret F: arr_Rel α F rewrites "F⦇ArrDom⦈ = A" and "F⦇ArrCod⦈ = B"
by (intro F)+
show "F ∈⇩∘ set {[r, A, B]⇩∘ | r A B. r ⊆⇩∘⋃⇩∘X ×⇩∘ ⋃⇩∘Y ∧ A ∈⇩∘ X ∧ B ∈⇩∘ Y}"
proof(intro in_set_CollectI small exI conjI)
from F.arr_Rel_def show "F = [F⦇ArrVal⦈, A, B]⇩∘" unfolding F(2,3) by simp
from A B have "A ×⇩∘ B ⊆⇩∘ ⋃⇩∘X ×⇩∘ ⋃⇩∘Y" by auto
moreover then have "F⦇ArrVal⦈ ⊆⇩∘ A ×⇩∘ B"
by (auto simp: F.arr_Rel_ArrVal_vsubset_ArrDom_ArrCod)
ultimately show "F⦇ArrVal⦈ ⊆⇩∘ ⋃⇩∘X ×⇩∘ ⋃⇩∘Y" by auto
qed (intro A B)+
qed
ultimately show "(⋃⇩∘A∈⇩∘X. ⋃⇩∘B∈⇩∘Y. Hom (dg_Rel α) A B) ∈⇩∘ Vset α" by blast
qed
lemma (in 𝒵) digraph_dg_Rel: "digraph α (dg_Rel α)"
proof(intro digraphI)
show "vfsequence (dg_Rel α)" unfolding dg_Rel_def by clarsimp
show "vcard (dg_Rel α) = 4⇩ℕ"
unfolding dg_Rel_def by (simp add: nat_omega_simps)
show "ℛ⇩∘ (dg_Rel α⦇Dom⦈) ⊆⇩∘ dg_Rel α⦇Obj⦈" by (simp add: dg_Rel_Dom_vrange)
show "ℛ⇩∘ (dg_Rel α⦇Cod⦈) ⊆⇩∘ dg_Rel α⦇Obj⦈" by (simp add: dg_Rel_Cod_vrange)
qed (auto simp: dg_Rel_components dg_Rel_Hom_vifunion_in_Vset dg_Rel_Dom_vrange)
subsection‹Canonical dagger for ‹Rel››
text‹
Dagger categories are exposed explicitly later.
In the context of this section, the ``dagger'' is viewed merely as
an explicitly defined homomorphism. A definition of a dagger functor, upon
which the definition presented in this section is based, can be found in nLab
\cite{noauthor_nlab_nodate}\footnote{\url{https://ncatlab.org/nlab/show/Rel})}.
This reference also contains the majority of the results that are presented
in this subsection.
›
subsubsection‹Definition and elementary properties›
definition dghm_dag_Rel :: "V ⇒ V" (‹†⇩D⇩G⇩.⇩R⇩e⇩l›)
where "†⇩D⇩G⇩.⇩R⇩e⇩l α =
[
vid_on (dg_Rel α⦇Obj⦈),
VLambda (dg_Rel α⦇Arr⦈) converse_Rel,
op_dg (dg_Rel α),
dg_Rel α
]⇩∘"
text‹Components.›
lemma dghm_dag_Rel_components:
shows "†⇩D⇩G⇩.⇩R⇩e⇩l α⦇ObjMap⦈ = vid_on (dg_Rel α⦇Obj⦈)"
and "†⇩D⇩G⇩.⇩R⇩e⇩l α⦇ArrMap⦈ = VLambda (dg_Rel α⦇Arr⦈) converse_Rel"
and "†⇩D⇩G⇩.⇩R⇩e⇩l α⦇HomDom⦈ = op_dg (dg_Rel α)"
and "†⇩D⇩G⇩.⇩R⇩e⇩l α⦇HomCod⦈ = dg_Rel α"
unfolding dghm_dag_Rel_def dghm_field_simps by (simp_all add: nat_omega_simps)
subsubsection‹Object map›
mk_VLambda dghm_dag_Rel_components(1)[folded VLambda_vid_on]
|vsv dghm_dag_Rel_ObjMap_vsv[dg_Rel_cs_intros]|
|vdomain
dghm_dag_Rel_ObjMap_vdomain[unfolded dg_Rel_components, dg_Rel_cs_simps]
|
|app dghm_dag_Rel_ObjMap_app[unfolded dg_Rel_components, dg_Rel_cs_simps]|
lemma dghm_dag_Rel_ObjMap_vrange[dg_cs_simps]: "ℛ⇩∘ (†⇩D⇩G⇩.⇩R⇩e⇩l α⦇ObjMap⦈) = Vset α"
unfolding dghm_dag_Rel_components dg_Rel_components by simp
subsubsection‹Arrow map›
mk_VLambda dghm_dag_Rel_components(2)
|vsv dghm_dag_Rel_ArrMap_vsv[dg_Rel_cs_intros]|
|vdomain dghm_dag_Rel_ArrMap_vdomain[dg_Rel_cs_simps]|
|app dghm_dag_Rel_ArrMap_app[unfolded dg_Rel_cs_simps, dg_Rel_cs_simps]|
subsubsection‹Further properties›
lemma dghm_dag_Rel_ArrMap_vrange[dg_Rel_cs_simps]:
"ℛ⇩∘ (†⇩D⇩G⇩.⇩R⇩e⇩l α⦇ArrMap⦈) = dg_Rel α⦇Arr⦈"
proof(intro vsubset_antisym vsubsetI)
interpret ArrMap: vsv ‹†⇩D⇩G⇩.⇩R⇩e⇩l α⦇ArrMap⦈›
unfolding dghm_dag_Rel_components by simp
fix T assume "T ∈⇩∘ ℛ⇩∘ (†⇩D⇩G⇩.⇩R⇩e⇩l α⦇ArrMap⦈)"
then obtain S where T_def: "T = †⇩D⇩G⇩.⇩R⇩e⇩l α⦇ArrMap⦈⦇S⦈"
and S: "S ∈⇩∘ 𝒟⇩∘ (†⇩D⇩G⇩.⇩R⇩e⇩l α⦇ArrMap⦈)"
by (blast dest: ArrMap.vrange_atD)
from S show "T ∈⇩∘ dg_Rel α⦇Arr⦈"
by
(
simp add:
T_def
dghm_dag_Rel_components
dg_Rel_components
arr_Rel.arr_Rel_converse_Rel
)
next
interpret ArrMap: vsv ‹†⇩D⇩G⇩.⇩R⇩e⇩l α⦇ArrMap⦈›
unfolding dghm_dag_Rel_components by simp
fix T assume "T ∈⇩∘ dg_Rel α⦇Arr⦈"
then have "arr_Rel α T" by (simp add: dg_Rel_components)
then have "(T¯⇩R⇩e⇩l)¯⇩R⇩e⇩l = T" and "arr_Rel α (T¯⇩R⇩e⇩l)"
by
(
auto simp:
arr_Rel.arr_Rel_converse_Rel_converse_Rel arr_Rel.arr_Rel_converse_Rel
)
then have "†⇩D⇩G⇩.⇩R⇩e⇩l α⦇ArrMap⦈⦇T¯⇩R⇩e⇩l⦈ = T" "T¯⇩R⇩e⇩l ∈⇩∘ 𝒟⇩∘ (†⇩D⇩G⇩.⇩R⇩e⇩l α⦇ArrMap⦈)"
by (simp_all add: dg_Rel_components(2) dghm_dag_Rel_components(2))
then show "T ∈⇩∘ ℛ⇩∘ (†⇩D⇩G⇩.⇩R⇩e⇩l α⦇ArrMap⦈)" by blast
qed
lemma dghm_dag_Rel_ArrMap_app_is_arr:
assumes "T : b ↦⇘dg_Rel α⇙ a"
shows
"†⇩D⇩G⇩.⇩R⇩e⇩l α⦇ArrMap⦈⦇T⦈ : †⇩D⇩G⇩.⇩R⇩e⇩l α⦇ObjMap⦈⦇a⦈ ↦⇘dg_Rel α⇙ †⇩D⇩G⇩.⇩R⇩e⇩l α⦇ObjMap⦈⦇b⦈"
proof(intro is_arrI)
from assms have a: "a ∈⇩∘ Vset α" and b: "b ∈⇩∘ Vset α"
unfolding dg_Rel_components by (fastforce simp: dg_Rel_components)+
from assms have T: "arr_Rel α T" by (auto simp: dg_Rel_is_arrD(1))
then show dag_T: "†⇩D⇩G⇩.⇩R⇩e⇩l α⦇ArrMap⦈⦇T⦈ ∈⇩∘ dg_Rel α⦇Arr⦈"
by (cs_concl cs_simp: dg_Rel_cs_simps cs_intro: dg_Rel_cs_intros)
from a assms T show "dg_Rel α⦇Dom⦈⦇†⇩D⇩G⇩.⇩R⇩e⇩l α⦇ArrMap⦈⦇T⦈⦈ = †⇩D⇩G⇩.⇩R⇩e⇩l α⦇ObjMap⦈⦇a⦈"
by (cs_concl cs_simp: dg_cs_simps dg_Rel_cs_simps cs_intro: dg_Rel_cs_intros)
from b assms T show "dg_Rel α⦇Cod⦈⦇†⇩D⇩G⇩.⇩R⇩e⇩l α⦇ArrMap⦈⦇T⦈⦈ = †⇩D⇩G⇩.⇩R⇩e⇩l α⦇ObjMap⦈⦇b⦈"
by (cs_concl cs_simp: dg_cs_simps dg_Rel_cs_simps cs_intro: dg_Rel_cs_intros)
qed
subsubsection‹Canonical dagger for ‹Rel› is a digraph isomorphism›
lemma (in 𝒵) dghm_dag_Rel_is_iso_dghm:
"†⇩D⇩G⇩.⇩R⇩e⇩l α : op_dg (dg_Rel α) ↦↦⇩D⇩G⇩.⇩i⇩s⇩o⇘α⇙ dg_Rel α"
proof(rule is_iso_dghmI)
interpret digraph α ‹dg_Rel α› by (simp add: digraph_dg_Rel)
show "†⇩D⇩G⇩.⇩R⇩e⇩l α : op_dg (dg_Rel α) ↦↦⇩D⇩G⇘α⇙ dg_Rel α"
proof(rule is_dghmI, unfold dg_op_simps dghm_dag_Rel_components(3,4))
show "vfsequence (†⇩D⇩G⇩.⇩R⇩e⇩l α)"
unfolding dghm_dag_Rel_def by (simp add: nat_omega_simps)
show "vcard (†⇩D⇩G⇩.⇩R⇩e⇩l α) = 4⇩ℕ"
unfolding dghm_dag_Rel_def by (simp add: nat_omega_simps)
fix T a b assume "T : b ↦⇘dg_Rel α⇙ a"
then show
"†⇩D⇩G⇩.⇩R⇩e⇩l α⦇ArrMap⦈⦇T⦈ : †⇩D⇩G⇩.⇩R⇩e⇩l α⦇ObjMap⦈⦇a⦈ ↦⇘dg_Rel α⇙ †⇩D⇩G⇩.⇩R⇩e⇩l α⦇ObjMap⦈⦇b⦈"
by (rule dghm_dag_Rel_ArrMap_app_is_arr)
qed (auto simp: dghm_dag_Rel_components intro: dg_cs_intros dg_op_intros)
show "v11 (†⇩D⇩G⇩.⇩R⇩e⇩l α⦇ArrMap⦈)"
proof
(
intro vsv.vsv_valeq_v11I,
unfold dghm_dag_Rel_ArrMap_vdomain dg_Rel_Arr_iff
)
fix S T assume prems:
"arr_Rel α S"
"arr_Rel α T"
"†⇩D⇩G⇩.⇩R⇩e⇩l α⦇ArrMap⦈⦇S⦈ = †⇩D⇩G⇩.⇩R⇩e⇩l α⦇ArrMap⦈⦇T⦈"
from prems show "S = T"
by
(
auto simp:
dg_Rel_components
dg_Rel_cs_simps
dghm_dag_Rel_ArrMap_app[OF prems(1)]
dghm_dag_Rel_ArrMap_app[OF prems(2)]
)
qed (auto intro: dg_Rel_cs_intros)
show "ℛ⇩∘ (†⇩D⇩G⇩.⇩R⇩e⇩l α⦇ArrMap⦈) = dg_Rel α⦇Arr⦈" by (simp add: dg_Rel_cs_simps)
qed (simp_all add: dghm_dag_Rel_components)
subsubsection‹Further properties of the canonical dagger›
lemma (in 𝒵) dghm_cn_comp_dghm_dag_Rel_dghm_dag_Rel:
"†⇩D⇩G⇩.⇩R⇩e⇩l α ⇩D⇩G⇩H⇩M∘ †⇩D⇩G⇩.⇩R⇩e⇩l α = dghm_id (dg_Rel α)"
proof-
interpret digraph α ‹dg_Rel α› by (simp add: digraph_dg_Rel)
from dghm_dag_Rel_is_iso_dghm have dag:
"†⇩D⇩G⇩.⇩R⇩e⇩l α : dg_Rel α ⇩D⇩G↦↦⇘α⇙ dg_Rel α"
by (simp add: is_iso_dghm_def)
show ?thesis
proof(rule dghm_eqI)
show "(†⇩D⇩G⇩.⇩R⇩e⇩l α ⇩D⇩G⇩H⇩M∘ †⇩D⇩G⇩.⇩R⇩e⇩l α)⦇ArrMap⦈ = dghm_id (dg_Rel α)⦇ArrMap⦈"
proof(rule vsv_eqI)
show "vsv ((†⇩D⇩G⇩.⇩R⇩e⇩l α ⇩D⇩G⇩H⇩M∘ †⇩D⇩G⇩.⇩R⇩e⇩l α)⦇ArrMap⦈)"
by (auto simp: dghm_cn_comp_components dghm_dag_Rel_components)
fix a assume "a ∈⇩∘ 𝒟⇩∘ ((†⇩D⇩G⇩.⇩R⇩e⇩l α ⇩D⇩G⇩H⇩M∘ †⇩D⇩G⇩.⇩R⇩e⇩l α)⦇ArrMap⦈)"
then have a: "arr_Rel α a"
unfolding dg_Rel_cs_simps dghm_cn_comp_ArrMap_vdomain[OF dag dag] by simp
from a dghm_dag_Rel_is_iso_dghm show
"(†⇩D⇩G⇩.⇩R⇩e⇩l α ⇩D⇩G⇩H⇩M∘ †⇩D⇩G⇩.⇩R⇩e⇩l α)⦇ArrMap⦈⦇a⦈ = dghm_id (dg_Rel α)⦇ArrMap⦈⦇a⦈"
by
(
cs_concl
cs_simp: dg_Rel_cs_simps dg_cs_simps dg_cn_cs_simps
cs_intro: dg_Rel_cs_intros dghm_cs_intros
)
qed (simp_all add: dghm_cn_comp_components dghm_id_components dg_Rel_cs_simps)
show "dghm_id (dg_Rel α) : dg_Rel α ↦↦⇩D⇩G⇘α⇙ dg_Rel α"
by (simp_all add: digraph.dg_dghm_id_is_dghm digraph_axioms)
qed
(
auto simp:
dghm_cn_comp_is_dghm[OF digraph_axioms dag dag]
dghm_cn_comp_components
dghm_dag_Rel_components
dghm_id_components
)
qed
text‹\newpage›
end
Theory CZH_DG_Par
section‹‹Par› as a digraph›
theory CZH_DG_Par
imports
CZH_DG_Rel
CZH_DG_Subdigraph
begin
subsection‹Background›
text‹
‹Par› is usually defined as a category of sets and partial functions
(see nLab \cite{noauthor_nlab_nodate}\footnote{
\url{https://ncatlab.org/nlab/show/partial+function}
}).
However, there is little that can prevent one from exposing ‹Par›
as a digraph and provide additional structure gradually in subsequent
installments of this work. Thus, in this section, ‹α›-‹Par› is defined as a
digraph of sets and partial functions in ‹V⇩α›
›
named_theorems dg_Par_cs_simps
named_theorems dg_Par_cs_intros
lemmas [dg_Par_cs_simps] = dg_Rel_shared_cs_simps
lemmas [dg_Par_cs_intros] = dg_Rel_shared_cs_intros
subsection‹Arrow for ‹Par››
subsubsection‹Definition and elementary properties›
locale arr_Par = 𝒵 α + vfsequence T + ArrVal: vsv ‹T⦇ArrVal⦈› for α T +
assumes arr_Par_length[dg_Rel_shared_cs_simps, dg_Par_cs_simps]:
"vcard T = 3⇩ℕ"
and arr_Par_ArrVal_vdomain: "𝒟⇩∘ (T⦇ArrVal⦈) ⊆⇩∘ T⦇ArrDom⦈"
and arr_Par_ArrVal_vrange: "ℛ⇩∘ (T⦇ArrVal⦈) ⊆⇩∘ T⦇ArrCod⦈"
and arr_Par_ArrDom_in_Vset: "T⦇ArrDom⦈ ∈⇩∘ Vset α"
and arr_Par_ArrCod_in_Vset: "T⦇ArrCod⦈ ∈⇩∘ Vset α"
text‹Elementary properties.›
sublocale arr_Par ⊆ arr_Rel
by unfold_locales
(
simp_all add:
dg_Par_cs_simps
arr_Par_ArrVal_vdomain
arr_Par_ArrVal_vrange
arr_Par_ArrDom_in_Vset
arr_Par_ArrCod_in_Vset
)
lemmas (in arr_Par) [dg_Par_cs_simps] = dg_Rel_shared_cs_simps
text‹Rules.›
mk_ide rf arr_Par_def[unfolded arr_Par_axioms_def]
|intro arr_ParI|
|dest arr_ParD[dest]|
|elim arr_ParE[elim!]|
lemma (in 𝒵) arr_Par_vfsequenceI:
assumes "vsv r"
and "𝒟⇩∘ r ⊆⇩∘ a"
and "ℛ⇩∘ r ⊆⇩∘ b"
and "a ∈⇩∘ Vset α"
and "b ∈⇩∘ Vset α"
shows "arr_Par α [r, a, b]⇩∘"
by (intro arr_ParI)
(insert assms, auto simp: arr_Rel_components nat_omega_simps)
lemma arr_Par_arr_RelI:
assumes "arr_Rel α T" and "vsv (T⦇ArrVal⦈)"
shows "arr_Par α T"
proof-
interpret arr_Rel α T by (rule assms(1))
show ?thesis
by (intro arr_ParI)
(
auto simp:
dg_Rel_cs_simps
assms(2)
vfsequence_axioms
arr_Rel_ArrVal_vdomain
arr_Rel_ArrVal_vrange
arr_Rel_ArrDom_in_Vset
arr_Rel_ArrCod_in_Vset
)
qed
lemma arr_Par_arr_RelD:
assumes "arr_Par α T"
shows "arr_Rel α T" and "vsv (T⦇ArrVal⦈)"
proof-
interpret arr_Par α T by (rule assms)
show "arr_Rel α T" and "vsv (T⦇ArrVal⦈)"
by (rule arr_Rel_axioms) auto
qed
lemma arr_Par_arr_RelE:
assumes "arr_Par α T"
obtains "arr_Rel α T" and "vsv (T⦇ArrVal⦈)"
using assms by (auto simp: arr_Par_arr_RelD)
text‹Further elementary properties.›
lemma arr_Par_eqI:
assumes "arr_Par α S"
and "arr_Par α T"
and "S⦇ArrVal⦈ = T⦇ArrVal⦈"
and "S⦇ArrDom⦈ = T⦇ArrDom⦈"
and "S⦇ArrCod⦈ = T⦇ArrCod⦈"
shows "S = T"
proof(rule vsv_eqI)
interpret S: arr_Par α S by (rule assms(1))
interpret T: arr_Par α T by (rule assms(2))
show "vsv S" by (rule S.vsv_axioms)
show "vsv T" by (rule T.vsv_axioms)
show "𝒟⇩∘ S = 𝒟⇩∘ T"
by (simp add: S.vfsequence_vdomain T.vfsequence_vdomain dg_Par_cs_simps)
have dom: "𝒟⇩∘ S = 3⇩ℕ" by (simp add: S.vfsequence_vdomain dg_Par_cs_simps)
show "a ∈⇩∘ 𝒟⇩∘ S ⟹ S⦇a⦈ = T⦇a⦈" for a
by (unfold dom, elim_in_numeral, insert assms)
(auto simp: arr_field_simps)
qed
lemma small_arr_Par[simp]: "small {T. arr_Par α T}"
proof(rule smaller_than_small)
show "{T. arr_Par α T} ⊆ {T. arr_Rel α T}"
by (simp add: Collect_mono arr_Par_arr_RelD(1))
qed simp
lemma set_Collect_arr_Par[simp]:
"T ∈⇩∘ set (Collect (arr_Par α)) ⟷ arr_Par α T"
by auto
subsubsection‹Composition›
abbreviation (input) comp_Par :: "V ⇒ V ⇒ V" (infixl ‹∘⇩P⇩a⇩r› 55)
where "comp_Par ≡ comp_Rel"
lemma arr_Par_comp_Par[dg_Par_cs_intros]:
assumes "arr_Par α S" and "arr_Par α T"
shows "arr_Par α (S ∘⇩P⇩a⇩r T)"
proof(intro arr_Par_arr_RelI)
interpret S: arr_Par α S by (rule assms(1))
interpret T: arr_Par α T by (rule assms(2))
show "arr_Rel α (S ∘⇩P⇩a⇩r T)"
by (auto simp: S.arr_Rel_axioms T.arr_Rel_axioms arr_Rel_comp_Rel)
show "vsv ((S ∘⇩P⇩a⇩r T)⦇ArrVal⦈)"
unfolding comp_Rel_components
by (simp add: S.ArrVal.vsv_axioms T.ArrVal.vsv_axioms vsv_vcomp)
qed
subsubsection‹Inclusion›
abbreviation (input) incl_Par :: "V ⇒ V ⇒ V"
where "incl_Par ≡ incl_Rel"
lemma (in 𝒵) arr_Par_incl_ParI:
assumes "A ∈⇩∘ Vset α" and "B ∈⇩∘ Vset α" and "A ⊆⇩∘ B"
shows "arr_Par α (incl_Par A B)"
proof(intro arr_Par_arr_RelI)
from assms show "arr_Rel α (incl_Par A B)"
by (force intro: arr_Rel_incl_RelI)
qed (simp add: incl_Rel_components)
subsubsection‹Identity›
abbreviation (input) id_Par :: "V ⇒ V"
where "id_Par ≡ id_Rel"
lemma (in 𝒵) arr_Par_id_ParI:
assumes "A ∈⇩∘ Vset α"
shows "arr_Par α (id_Par A)"
using assms
by (intro arr_Par_arr_RelI)
(auto intro: arr_Rel_id_RelI simp: id_Rel_components)
lemma arr_Par_comp_Par_id_Par_left[dg_Par_cs_simps]:
assumes "arr_Par α f" and "f⦇ArrCod⦈ = A"
shows "id_Par A ∘⇩R⇩e⇩l f = f"
proof-
interpret f: arr_Par α f by (rule assms(1))
have "arr_Rel α f" by (simp add: f.arr_Rel_axioms)
from arr_Rel_comp_Rel_id_Rel_left[OF this assms(2)] show ?thesis .
qed
lemma arr_Par_comp_Par_id_Par_right[dg_Par_cs_simps]:
assumes "arr_Par α f" and "f⦇ArrDom⦈ = A"
shows "f ∘⇩R⇩e⇩l id_Par A = f"
proof-
interpret f: arr_Par α f by (rule assms(1))
have "arr_Rel α f" by (simp add: f.arr_Rel_axioms)
from arr_Rel_comp_Rel_id_Rel_right[OF this assms(2)] show ?thesis.
qed
lemma arr_Par_comp_Par_ArrVal:
assumes "arr_Par α S"
and "arr_Par α T"
and "x ∈⇩∘ 𝒟⇩∘ (T⦇ArrVal⦈)"
and "T⦇ArrVal⦈⦇x⦈ ∈⇩∘ 𝒟⇩∘ (S⦇ArrVal⦈)"
shows "(S ∘⇩P⇩a⇩r T)⦇ArrVal⦈⦇x⦈ = S⦇ArrVal⦈⦇T⦇ArrVal⦈⦇x⦈⦈"
using assms
unfolding comp_Rel_components
by (intro vcomp_atI) auto
subsection‹‹Par› as a digraph›
subsubsection‹Definition and elementary properties›
definition dg_Par :: "V ⇒ V"
where "dg_Par α =
[
Vset α,
set {T. arr_Par α T},
(λT∈⇩∘set {T. arr_Par α T}. T⦇ArrDom⦈),
(λT∈⇩∘set {T. arr_Par α T}. T⦇ArrCod⦈)
]⇩∘"
text‹Components.›
lemma dg_Par_components:
shows "dg_Par α⦇Obj⦈ = Vset α"
and "dg_Par α⦇Arr⦈ = set {T. arr_Par α T}"
and "dg_Par α⦇Dom⦈ = (λT∈⇩∘set {T. arr_Par α T}. T⦇ArrDom⦈)"
and "dg_Par α⦇Cod⦈ = (λT∈⇩∘set {T. arr_Par α T}. T⦇ArrCod⦈)"
unfolding dg_Par_def dg_field_simps by (simp_all add: nat_omega_simps)
subsubsection‹Object›
lemma dg_Par_Obj_iff: "x ∈⇩∘ dg_Par α⦇Obj⦈ ⟷ x ∈⇩∘ Vset α"
unfolding dg_Par_components by auto
subsubsection‹Arrow›
lemma dg_Par_Arr_iff[dg_Par_cs_simps]: "x ∈⇩∘ dg_Par α⦇Arr⦈ ⟷ arr_Par α x"
unfolding dg_Par_components by auto
subsubsection‹Domain›
mk_VLambda dg_Par_components(3)
|vsv dg_Par_Dom_vsv[dg_Par_cs_intros]|
|vdomain dg_Par_Dom_vdomain[dg_Par_cs_simps]|
|app dg_Par_Dom_app[unfolded set_Collect_arr_Par, dg_Par_cs_simps]|
lemma dg_Par_Dom_vrange: "ℛ⇩∘ (dg_Par α⦇Dom⦈) ⊆⇩∘ dg_Par α⦇Obj⦈"
unfolding dg_Par_components
by (rule vrange_VLambda_vsubset, unfold set_Collect_arr_Par) auto
subsubsection‹Codomain›
mk_VLambda dg_Par_components(4)
|vsv dg_Par_Cod_vsv[dg_Par_cs_intros]|
|vdomain dg_Par_Cod_vdomain[dg_Par_cs_simps]|
|app dg_Par_Cod_app[unfolded set_Collect_arr_Par, dg_Par_cs_simps]|
lemma dg_Par_Cod_vrange: "ℛ⇩∘ (dg_Par α⦇Cod⦈) ⊆⇩∘ dg_Par α⦇Obj⦈"
unfolding dg_Par_components
by (rule vrange_VLambda_vsubset, unfold set_Collect_arr_Par) auto
subsubsection‹Arrow with a domain and a codomain›
text‹Rules.›
lemma dg_Par_is_arrI:
assumes "arr_Par α S" and "S⦇ArrDom⦈ = A" and "S⦇ArrCod⦈ = B"
shows "S : A ↦⇘dg_Par α⇙ B"
using assms by (intro is_arrI, unfold dg_Par_components) simp_all
lemmas [dg_Par_cs_intros] = dg_Par_is_arrI
lemma dg_Par_is_arrD:
assumes "S : A ↦⇘dg_Par α⇙ B"
shows "arr_Par α S"
and [dg_cs_simps]: "S⦇ArrDom⦈ = A"
and [dg_cs_simps]: "S⦇ArrCod⦈ = B"
using is_arrD[OF assms] unfolding dg_Par_components by simp_all
lemma dg_Par_is_arrE:
assumes "S : A ↦⇘dg_Par α⇙ B"
obtains "arr_Par α S" and "S⦇ArrDom⦈ = A" and "S⦇ArrCod⦈ = B"
using is_arrD[OF assms] unfolding dg_Par_components by simp_all
text‹Elementary properties.›
lemma dg_Par_is_arr_dg_Rel_is_arr:
assumes "r : a ↦⇘dg_Par α⇙ b"
shows "r : a ↦⇘dg_Rel α⇙ b"
using assms arr_Par_arr_RelD(1)
by (intro dg_Rel_is_arrI; elim dg_Par_is_arrE) auto
lemma dg_Par_Hom_vsubset_dg_Rel_Hom:
assumes "a ∈⇩∘ dg_Par α⦇Obj⦈" "b ∈⇩∘ dg_Par α⦇Obj⦈"
shows "Hom (dg_Par α) a b ⊆⇩∘ Hom (dg_Rel α) a b"
by (rule vsubsetI) (simp add: dg_Par_is_arr_dg_Rel_is_arr)
lemma (in 𝒵) dg_Par_incl_Par_is_arr:
assumes "A ∈⇩∘ Vset α" and "B ∈⇩∘ Vset α" and "A ⊆⇩∘ B"
shows "incl_Par A B : A ↦⇘dg_Par α⇙ B"
by (rule dg_Par_is_arrI)
(auto simp: incl_Rel_components intro!: arr_Par_incl_ParI assms)
lemma (in 𝒵) dg_Par_incl_Par_is_arr'[dg_Par_cs_intros]:
assumes "A ∈⇩∘ Vset α"
and "B ∈⇩∘ Vset α"
and "A ⊆⇩∘ B"
and "A' = A"
and "B' = B"
shows "incl_Par A B : A' ↦⇘dg_Par α⇙ B'"
using assms(1-3) unfolding assms(4,5) by (rule dg_Par_incl_Par_is_arr)
lemmas [dg_Par_cs_intros] = 𝒵.dg_Par_incl_Par_is_arr'
subsubsection‹‹Par› is a digraph›
lemma (in 𝒵) dg_Par_Hom_vifunion_in_Vset:
assumes "X ∈⇩∘ Vset α" and "Y ∈⇩∘ Vset α"
shows "(⋃⇩∘A∈⇩∘X. ⋃⇩∘B∈⇩∘Y. Hom (dg_Par α) A B) ∈⇩∘ Vset α"
proof-
have
"(⋃⇩∘A∈⇩∘X. ⋃⇩∘B∈⇩∘Y. Hom (dg_Par α) A B) ⊆⇩∘
(⋃⇩∘A∈⇩∘X. ⋃⇩∘B∈⇩∘Y. Hom (dg_Rel α) A B)"
proof(intro vsubsetI)
fix F assume "F ∈⇩∘ (⋃⇩∘A∈⇩∘X. ⋃⇩∘B∈⇩∘Y. Hom (dg_Par α) A B)"
then obtain B where B: "B ∈⇩∘ Y" and "F ∈⇩∘ (⋃⇩∘A∈⇩∘X. Hom (dg_Par α) A B)"
by fast
then obtain A where A: "A ∈⇩∘ X" and F_AB: "F ∈⇩∘ Hom (dg_Par α) A B" by fast
from A B assms have "A ∈⇩∘ dg_Par α⦇Obj⦈" "B ∈⇩∘ dg_Par α⦇Obj⦈"
unfolding dg_Par_components by auto
from F_AB A B dg_Par_Hom_vsubset_dg_Rel_Hom[OF this] show
"F ∈⇩∘ (⋃⇩∘A∈⇩∘X. ⋃⇩∘B∈⇩∘Y. Hom (dg_Rel α) A B)"
by (intro vifunionI) (auto elim!: vsubsetE simp: in_Hom_iff)
qed
with dg_Rel_Hom_vifunion_in_Vset[OF assms] show ?thesis by blast
qed
lemma (in 𝒵) digraph_dg_Par: "digraph α (dg_Par α)"
proof(intro digraphI)
show "vfsequence (dg_Par α)" unfolding dg_Par_def by simp
show "vcard (dg_Par α) = 4⇩ℕ"
unfolding dg_Par_def by (simp add: nat_omega_simps)
show "ℛ⇩∘ (dg_Par α⦇Dom⦈) ⊆⇩∘ dg_Par α⦇Obj⦈" by (simp add: dg_Par_Dom_vrange)
show "ℛ⇩∘ (dg_Par α⦇Cod⦈) ⊆⇩∘ dg_Par α⦇Obj⦈" by (simp add: dg_Par_Cod_vrange)
qed (auto simp: dg_Par_components dg_Par_Hom_vifunion_in_Vset)
subsubsection‹‹Par› is a wide subdigraph of ‹Rel››
lemma (in 𝒵) wide_subdigraph_dg_Par_dg_Rel: "dg_Par α ⊆⇩D⇩G⇩.⇩w⇩i⇩d⇩e⇘α⇙ dg_Rel α"
proof(intro wide_subdigraphI)
show "dg_Par α ⊆⇩D⇩G⇘α⇙ dg_Rel α"
by (intro subdigraphI, unfold dg_Par_components)
(
auto simp:
dg_Rel_components
digraph_dg_Par
digraph_dg_Rel
dg_Par_is_arr_dg_Rel_is_arr
)
qed (simp_all add: dg_Rel_components dg_Par_components)
text‹\newpage›
end
Theory CZH_DG_Set
section‹‹Set› as a digraph›
theory CZH_DG_Set
imports CZH_DG_Par
begin
subsection‹Background›
text‹
‹Set› is usually defined as a category of sets and total functions
(see Chapter I-2 in \cite{mac_lane_categories_2010}). However, there
is little that can prevent one from exposing ‹Set› as a digraph and
provide additional structure gradually in subsequent installments of this
work. Thus, in this section, ‹α›-‹Set› is defined as a digraph of sets
and binary relations in the set ‹V⇩α›.
›
named_theorems dg_Set_cs_simps
named_theorems dg_Set_cs_intros
lemmas [dg_Set_cs_simps] = dg_Rel_shared_cs_simps
lemmas [dg_Set_cs_intros] = dg_Rel_shared_cs_intros
subsection‹Arrow for ‹Set››
subsubsection‹Definition and elementary properties›
locale arr_Set = 𝒵 α + vfsequence T + ArrVal: vsv ‹T⦇ArrVal⦈› for α T +
assumes arr_Set_length[dg_Rel_shared_cs_simps, dg_Set_cs_simps]:
"vcard T = 3⇩ℕ"
and arr_Set_ArrVal_vdomain[dg_Rel_shared_cs_simps, dg_Set_cs_simps]:
"𝒟⇩∘ (T⦇ArrVal⦈) = T⦇ArrDom⦈"
and arr_Set_ArrVal_vrange: "ℛ⇩∘ (T⦇ArrVal⦈) ⊆⇩∘ T⦇ArrCod⦈"
and arr_Set_ArrDom_in_Vset: "T⦇ArrDom⦈ ∈⇩∘ Vset α"
and arr_Set_ArrCod_in_Vset: "T⦇ArrCod⦈ ∈⇩∘ Vset α"
lemmas [dg_Set_cs_simps] = arr_Set.arr_Set_ArrVal_vdomain
text‹Elementary properties.›
sublocale arr_Set ⊆ arr_Par
by unfold_locales
(
simp_all add:
dg_Set_cs_simps
arr_Set_ArrVal_vrange arr_Set_ArrDom_in_Vset arr_Set_ArrCod_in_Vset
)
text‹Rules.›
mk_ide rf arr_Set_def[unfolded arr_Set_axioms_def]
|intro arr_SetI|
|dest arr_SetD[dest]|
|elim arr_SetE[elim!]|
lemma (in 𝒵) arr_Set_vfsequenceI:
assumes "vsv r"
and "𝒟⇩∘ r = a"
and "ℛ⇩∘ r ⊆⇩∘ b"
and "a ∈⇩∘ Vset α"
and "b ∈⇩∘ Vset α"
shows "arr_Set α [r, a, b]⇩∘"
by (intro arr_SetI)
(insert assms, auto simp: arr_Rel_components nat_omega_simps)
lemma arr_Set_arr_ParI:
assumes "arr_Par α T" and "𝒟⇩∘ (T⦇ArrVal⦈) = T⦇ArrDom⦈"
shows "arr_Set α T"
proof-
interpret arr_Par α T by (rule assms(1))
show ?thesis
by (intro arr_SetI)
(
auto simp:
dg_Par_cs_simps
assms(2)
vfsequence_axioms
arr_Rel_ArrVal_vrange
arr_Rel_ArrDom_in_Vset
arr_Rel_ArrCod_in_Vset
)
qed
lemma arr_Set_arr_ParD:
assumes "arr_Set α T"
shows "arr_Par α T" and "𝒟⇩∘ (T⦇ArrVal⦈) = T⦇ArrDom⦈"
proof-
interpret arr_Set α T by (rule assms)
show "arr_Par α T" and "𝒟⇩∘ (T⦇ArrVal⦈) = T⦇ArrDom⦈"
by (rule arr_Par_axioms) (auto simp: dg_Set_cs_simps)
qed
lemma arr_Set_arr_ParE:
assumes "arr_Set α T"
obtains "arr_Par α T" and "𝒟⇩∘ (T⦇ArrVal⦈) = T⦇ArrDom⦈"
using assms by (auto simp: arr_Set_arr_ParD)
text‹Further elementary properties.›
lemma arr_Set_eqI:
assumes "arr_Set α S"
and "arr_Set α T"
and "S⦇ArrVal⦈ = T⦇ArrVal⦈"
and "S⦇ArrDom⦈ = T⦇ArrDom⦈"
and "S⦇ArrCod⦈ = T⦇ArrCod⦈"
shows "S = T"
proof-
interpret S: arr_Set α S by (rule assms(1))
interpret T: arr_Set α T by (rule assms(2))
show ?thesis
proof(rule vsv_eqI)
have dom: "𝒟⇩∘ S = 3⇩ℕ" by (simp add: S.vfsequence_vdomain dg_Set_cs_simps)
show "a ∈⇩∘ 𝒟⇩∘ S ⟹ S⦇a⦈ = T⦇a⦈" for a
by (unfold dom, elim_in_numeral, insert assms)
(auto simp: arr_field_simps)
qed (auto simp: S.vfsequence_vdomain T.vfsequence_vdomain dg_Set_cs_simps)
qed
lemma small_arr_Set[simp]: "small {T. arr_Set α T}"
proof(rule smaller_than_small)
show "{T. arr_Set α T} ⊆ {T. arr_Par α T}"
by (simp add: Collect_mono arr_Set_arr_ParD(1))
qed simp
lemma set_Collect_arr_Set[simp]:
"T ∈⇩∘ set (Collect (arr_Set α)) ⟷ arr_Set α T"
by auto
subsubsection‹Composition›
text‹See \cite{mac_lane_categories_2010}).›
abbreviation (input) comp_Set :: "V ⇒ V ⇒ V" (infixl ‹∘⇩S⇩e⇩t› 55)
where "comp_Set ≡ comp_Rel"
lemma arr_Set_comp_Set[dg_Set_cs_intros]:
assumes "arr_Set α S" and "arr_Set α T" and "ℛ⇩∘ (T⦇ArrVal⦈) ⊆⇩∘ 𝒟⇩∘ (S⦇ArrVal⦈)"
shows "arr_Set α (S ∘⇩S⇩e⇩t T)"
proof(intro arr_Set_arr_ParI)
interpret S: arr_Set α S by (rule assms(1))
interpret T: arr_Set α T by (rule assms(2))
show "arr_Par α (S ∘⇩S⇩e⇩t T)"
by (auto simp: S.arr_Par_axioms T.arr_Par_axioms arr_Par_comp_Par)
show "𝒟⇩∘ ((S ∘⇩R⇩e⇩l T)⦇ArrVal⦈) = (S ∘⇩R⇩e⇩l T)⦇ArrDom⦈"
unfolding comp_Rel_components vdomain_vcomp_vsubset[OF assms(3)]
by (simp add: dg_Set_cs_simps)
qed
subsubsection‹Inclusion›
abbreviation (input) incl_Set :: "V ⇒ V ⇒ V"
where "incl_Set ≡ incl_Rel"
lemma (in 𝒵) arr_Set_incl_SetI:
assumes "A ∈⇩∘ Vset α" and "B ∈⇩∘ Vset α" and "A ⊆⇩∘ B"
shows "arr_Set α (incl_Set A B)"
proof(intro arr_Set_arr_ParI)
from assms show "arr_Par α (incl_Set A B)"
by (force intro: arr_Par_incl_ParI)
qed (simp add: incl_Rel_components)
subsubsection‹Identity›
abbreviation (input) id_Set :: "V ⇒ V"
where "id_Set ≡ id_Rel"
lemma (in 𝒵) arr_Set_id_SetI:
assumes "A ∈⇩∘ Vset α"
shows "arr_Set α (id_Set A)"
proof(intro arr_Set_arr_ParI)
from assms show "arr_Par α (id_Par A)"
by (force intro: arr_Par_id_ParI)
qed (simp add: id_Rel_components)
lemma arr_Set_comp_Set_id_Set_left[dg_Set_cs_simps]:
assumes "arr_Set α F" and "F⦇ArrCod⦈ = A"
shows "id_Set A ∘⇩R⇩e⇩l F = F"
proof-
interpret F: arr_Set α F by (rule assms(1))
have "arr_Rel α F" by (simp add: F.arr_Rel_axioms)
from arr_Rel_comp_Rel_id_Rel_left[OF this assms(2)] show ?thesis.
qed
lemma arr_Set_comp_Set_id_Set_right[dg_Set_cs_simps]:
assumes "arr_Set α F" and "F⦇ArrDom⦈ = A"
shows "F ∘⇩R⇩e⇩l id_Set A = F"
proof-
interpret F: arr_Set α F by (rule assms(1))
have "arr_Rel α F" by (simp add: F.arr_Rel_axioms)
from arr_Rel_comp_Rel_id_Rel_right[OF this assms(2)] show ?thesis.
qed
lemma arr_Set_comp_Set_ArrVal:
assumes "arr_Set α S"
and "arr_Set α T"
and "x ∈⇩∘ 𝒟⇩∘ (T⦇ArrVal⦈)"
and "T⦇ArrVal⦈⦇x⦈ ∈⇩∘ 𝒟⇩∘ (S⦇ArrVal⦈)"
shows "(S ∘⇩S⇩e⇩t T)⦇ArrVal⦈⦇x⦈ = S⦇ArrVal⦈⦇T⦇ArrVal⦈⦇x⦈⦈"
proof-
interpret S: arr_Set α S + T: arr_Set α T by (simp_all add: assms(1,2))
from assms show ?thesis
unfolding comp_Rel_components by (intro vcomp_atI) auto
qed
subsection‹‹Set› as a digraph›
subsubsection‹Definition and elementary properties›
definition dg_Set :: "V ⇒ V"
where "dg_Set α =
[
Vset α,
set {T. arr_Set α T},
(λT∈⇩∘set {T. arr_Set α T}. T⦇ArrDom⦈),
(λT∈⇩∘set {T. arr_Set α T}. T⦇ArrCod⦈)
]⇩∘"
text‹Components.›
lemma dg_Set_components:
shows "dg_Set α⦇Obj⦈ = Vset α"
and "dg_Set α⦇Arr⦈ = set {T. arr_Set α T}"
and "dg_Set α⦇Dom⦈ = (λT∈⇩∘set {T. arr_Set α T}. T⦇ArrDom⦈)"
and "dg_Set α⦇Cod⦈ = (λT∈⇩∘set {T. arr_Set α T}. T⦇ArrCod⦈)"
unfolding dg_Set_def dg_field_simps by (simp_all add: nat_omega_simps)
subsubsection‹Object›
lemma dg_Set_Obj_iff: "x ∈⇩∘ dg_Set α⦇Obj⦈ ⟷ x ∈⇩∘ Vset α"
unfolding dg_Set_components by auto
subsubsection‹Arrow›
lemma dg_Set_Arr_iff[dg_Set_cs_simps]: "x ∈⇩∘ dg_Set α⦇Arr⦈ ⟷ arr_Set α x"
unfolding dg_Set_components by auto
subsubsection‹Domain›
mk_VLambda dg_Set_components(3)
|vsv dg_Set_Dom_vsv[dg_Set_cs_intros]|
|vdomain dg_Set_Dom_vdomain[dg_Set_cs_simps]|
|app dg_Set_Dom_app[unfolded set_Collect_arr_Set, dg_Set_cs_simps]|
lemma dg_Set_Dom_vrange: "ℛ⇩∘ (dg_Set α⦇Dom⦈) ⊆⇩∘ dg_Set α⦇Obj⦈"
unfolding dg_Set_components
by (rule vrange_VLambda_vsubset, unfold set_Collect_arr_Set) auto
subsubsection‹Codomain›
mk_VLambda dg_Set_components(4)
|vsv dg_Set_Cod_vsv[dg_Set_cs_intros]|
|vdomain dg_Set_Cod_vdomain[dg_Set_cs_simps]|
|app dg_Set_Cod_app[unfolded set_Collect_arr_Set, dg_Set_cs_simps]|
lemma dg_Set_Cod_vrange: "ℛ⇩∘ (dg_Set α⦇Cod⦈) ⊆⇩∘ dg_Set α⦇Obj⦈"
unfolding dg_Set_components
by (rule vrange_VLambda_vsubset, unfold set_Collect_arr_Set) auto
subsubsection‹Arrow with a domain and a codomain›
text‹Rules.›
lemma dg_Set_is_arrI[dg_Set_cs_intros]:
assumes "arr_Set α S" and "S⦇ArrDom⦈ = A" and "S⦇ArrCod⦈ = B"
shows "S : A ↦⇘dg_Set α⇙ B"
using assms by (intro is_arrI, unfold dg_Set_components) simp_all
lemma dg_Set_is_arrD:
assumes "S : A ↦⇘dg_Set α⇙ B"
shows "arr_Set α S"
and [dg_cs_simps]: "S⦇ArrDom⦈ = A"
and [dg_cs_simps]: "S⦇ArrCod⦈ = B"
using is_arrD[OF assms] unfolding dg_Set_components by simp_all
lemma dg_Set_is_arrE:
assumes "S : A ↦⇘dg_Set α⇙ B"
obtains "arr_Set α S" and "S⦇ArrDom⦈ = A" and "S⦇ArrCod⦈ = B"
using is_arrD[OF assms] unfolding dg_Set_components by simp_all
lemma dg_Set_ArrVal_vdomain[dg_Set_cs_simps, dg_cs_simps]:
assumes "T : A ↦⇘dg_Set α⇙ B"
shows "𝒟⇩∘ (T⦇ArrVal⦈) = A"
proof-
interpret T: arr_Set α T using assms by (auto simp: dg_Set_is_arrD)
from assms show ?thesis by (auto simp: dg_Set_is_arrD dg_Set_cs_simps)
qed
text‹Elementary properties.›
lemma dg_Set_ArrVal_app_vrange[dg_Set_cs_intros]:
assumes "F : A ↦⇘dg_Set α⇙ B" and "a ∈⇩∘ A"
shows "F⦇ArrVal⦈⦇a⦈ ∈⇩∘ B"
proof-
interpret F: arr_Set α F
rewrites "F⦇ArrDom⦈ = A" and "F⦇ArrCod⦈ = B"
by (intro dg_Set_is_arrD[OF assms(1)])+
from assms F.arr_Par_ArrVal_vrange show ?thesis
by (auto simp: F.ArrVal.vsv_vimageI2 vsubset_iff dg_Set_cs_simps)
qed
lemma dg_Set_is_arr_dg_Par_is_arr:
assumes "T : A ↦⇘dg_Set α⇙ B"
shows "T : A ↦⇘dg_Par α⇙ B"
using assms arr_Set_arr_ParD(1)
by (intro dg_Par_is_arrI; elim dg_Set_is_arrE) auto
lemma dg_Set_Hom_vsubset_dg_Par_Hom:
assumes "a ∈⇩∘ dg_Set α⦇Obj⦈" "b ∈⇩∘ dg_Set α⦇Obj⦈"
shows "Hom (dg_Set α) a b ⊆⇩∘ Hom (dg_Par α) a b"
by (rule vsubsetI) (simp add: dg_Set_is_arr_dg_Par_is_arr)
lemma (in 𝒵) dg_Set_incl_Set_is_arr:
assumes "A ∈⇩∘ Vset α" and "B ∈⇩∘ Vset α" and "A ⊆⇩∘ B"
shows "incl_Set A B : A ↦⇘dg_Set α⇙ B"
proof(rule dg_Set_is_arrI)
show "arr_Set α (incl_Set A B)" by (intro arr_Set_incl_SetI assms)
qed (simp_all add: incl_Rel_components)
lemma (in 𝒵) dg_Set_incl_Set_is_arr'[dg_Set_cs_intros]:
assumes "A ∈⇩∘ Vset α"
and "B ∈⇩∘ Vset α"
and "A ⊆⇩∘ B"
and "A' = A"
and "B' = B"
shows "incl_Set A B : A' ↦⇘dg_Set α⇙ B'"
using assms(1-3) unfolding assms(4,5) by (rule dg_Set_incl_Set_is_arr)
lemmas [dg_Set_cs_intros] = 𝒵.dg_Set_incl_Set_is_arr'
subsubsection‹‹Set› is a digraph›
lemma (in 𝒵) dg_Set_Hom_vifunion_in_Vset:
assumes "X ∈⇩∘ Vset α" and "Y ∈⇩∘ Vset α"
shows "(⋃⇩∘A∈⇩∘X. ⋃⇩∘B∈⇩∘Y. Hom (dg_Set α) A B) ∈⇩∘ Vset α"
proof-
have
"(⋃⇩∘A∈⇩∘X. ⋃⇩∘B∈⇩∘Y. Hom (dg_Set α) A B) ⊆⇩∘
(⋃⇩∘A∈⇩∘X. ⋃⇩∘B∈⇩∘Y. Hom (dg_Par α) A B)"
proof
fix F assume "F ∈⇩∘ (⋃⇩∘A∈⇩∘X. ⋃⇩∘B∈⇩∘Y. Hom (dg_Set α) A B)"
then obtain B where B: "B ∈⇩∘ Y" and F_b:
"F ∈⇩∘ (⋃⇩∘A∈⇩∘X. Hom (dg_Set α) A B)"
by fast
then obtain A where A: "A ∈⇩∘ X" and F_AB: "F ∈⇩∘ Hom (dg_Set α) A B"
by fast
from A B assms have "A ∈⇩∘ dg_Set α⦇Obj⦈" "B ∈⇩∘ dg_Set α⦇Obj⦈"
unfolding dg_Set_components by auto
from F_AB A B dg_Set_Hom_vsubset_dg_Par_Hom[OF this] show
"F ∈⇩∘ (⋃⇩∘A∈⇩∘X. ⋃⇩∘B∈⇩∘Y. Hom (dg_Par α) A B)"
by (intro vifunionI) (auto elim!: vsubsetE simp: in_Hom_iff)
qed
with dg_Par_Hom_vifunion_in_Vset[OF assms] show ?thesis by blast
qed
lemma (in 𝒵) digraph_dg_Set: "digraph α (dg_Set α)"
proof(intro digraphI)
show "vfsequence (dg_Set α)" unfolding dg_Set_def by simp
show "vcard (dg_Set α) = 4⇩ℕ"
unfolding dg_Set_def by (simp add: nat_omega_simps)
show "ℛ⇩∘ (dg_Set α⦇Dom⦈) ⊆⇩∘ dg_Set α⦇Obj⦈" by (simp add: dg_Set_Dom_vrange)
show "ℛ⇩∘ (dg_Set α⦇Cod⦈) ⊆⇩∘ dg_Set α⦇Obj⦈" by (simp add: dg_Set_Cod_vrange)
qed (auto simp: dg_Set_components dg_Set_Hom_vifunion_in_Vset)
subsubsection‹‹Set› is a wide subdigraph of ‹Par››
lemma (in 𝒵) wide_subdigraph_dg_Set_dg_Par: "dg_Set α ⊆⇩D⇩G⇩.⇩w⇩i⇩d⇩e⇘α⇙ dg_Par α"
proof(intro wide_subdigraphI)
interpret Set: digraph α ‹dg_Set α› by (rule digraph_dg_Set)
interpret Par: digraph α ‹dg_Par α› by (rule digraph_dg_Par)
show "dg_Set α ⊆⇩D⇩G⇘α⇙ dg_Par α"
proof(intro subdigraphI, unfold dg_Set_components)
show "F : A ↦⇘dg_Par α⇙ B" if "F : A ↦⇘dg_Set α⇙ B" for F A B
using that by (rule dg_Set_is_arr_dg_Par_is_arr)
qed (auto simp: dg_Par_components digraph_dg_Set digraph_dg_Par)
qed (simp_all add: dg_Par_components dg_Set_components)
text‹\newpage›
end
Theory CZH_SMC_Introduction
chapter‹Semicategories›
section‹Introduction›
theory CZH_SMC_Introduction
imports CZH_DG_Introduction
begin
subsection‹Background›
text‹
Many concepts that are normally associated with category theory can be
generalized to semicategories. It is the goal of
this chapter to expose these generalized concepts and provide the
relevant foundations for the development of the notion of a category
in the next chapter.
›
subsection‹Preliminaries›
named_theorems smc_op_simps
named_theorems smc_op_intros
named_theorems smc_cs_simps
named_theorems smc_cs_intros
named_theorems smc_arrow_cs_intros
subsection‹CS setup for foundations›
lemmas (in 𝒵) [smc_cs_intros] = 𝒵_β
text‹\newpage›
end
Theory CZH_SMC_Semicategory
section‹Semicategory›
theory CZH_SMC_Semicategory
imports
CZH_DG_Digraph
CZH_SMC_Introduction
begin
subsection‹Background›
lemmas [smc_cs_simps] = dg_shared_cs_simps
lemmas [smc_cs_intros] = dg_shared_cs_intros
subsubsection‹Slicing›
text‹
‹Slicing› is a term that is introduced in this work for the description
of the process of the conversion of more specialized mathematical objects to
their generalizations.
The terminology was adapted from the informal imperative
object oriented programming, where the term slicing often refers to the
process of copying an object of a subclass type to an object of a
superclass type \cite{noauthor_wikipedia_2001}\footnote{
\url{https://en.wikipedia.org/wiki/Object_slicing}
}.
However, it is important to note that the term has other meanings in
programming and computer science.
›
definition smc_dg :: "V ⇒ V"
where "smc_dg ℭ = [ℭ⦇Obj⦈, ℭ⦇Arr⦈, ℭ⦇Dom⦈, ℭ⦇Cod⦈]⇩∘"
text‹Components.›
lemma smc_dg_components[slicing_simps]:
shows "smc_dg ℭ⦇Obj⦈ = ℭ⦇Obj⦈"
and "smc_dg ℭ⦇Arr⦈ = ℭ⦇Arr⦈"
and "smc_dg ℭ⦇Dom⦈ = ℭ⦇Dom⦈"
and "smc_dg ℭ⦇Cod⦈ = ℭ⦇Cod⦈"
unfolding smc_dg_def dg_field_simps by (auto simp: nat_omega_simps)
text‹Regular definitions.›
lemma smc_dg_is_arr[slicing_simps]: "f : a ↦⇘smc_dg ℭ⇙ b ⟷ f : a ↦⇘ℭ⇙ b"
unfolding is_arr_def slicing_simps ..
lemmas [slicing_intros] = smc_dg_is_arr[THEN iffD2]
subsubsection‹Composition and composable arrows›
text‹
The definition of a set of ‹composable_arrs› is equivalent to the definition
of ‹composable pairs› presented on page 10 in \cite{mac_lane_categories_2010}
(see theorem ‹dg_composable_arrs'› below).
Nonetheless, the definition is meant to be used sparingly. Normally,
the arrows are meant to be specified explicitly using the predicate
\<^const>‹is_arr›.
›
definition Comp :: V
where [dg_field_simps]: "Comp = 4⇩ℕ"
abbreviation Comp_app :: "V ⇒ V ⇒ V ⇒ V" (infixl "∘⇩Aı" 55)
where "Comp_app ℭ a b ≡ ℭ⦇Comp⦈⦇a, b⦈⇩∙"
definition composable_arrs :: "V ⇒ V"
where "composable_arrs ℭ = set
{[g, f]⇩∘ | g f. ∃a b c. g : b ↦⇘ℭ⇙ c ∧ f : a ↦⇘ℭ⇙ b}"
lemma small_composable_arrs[simp]:
"small {[g, f]⇩∘ | g f. ∃a b c. g : b ↦⇘ℭ⇙ c ∧ f : a ↦⇘ℭ⇙ b}"
proof(intro down[of _ ‹ℭ⦇Arr⦈ ^⇩× 2⇩ℕ›] subsetI)
fix x assume "x ∈ {[g, f]⇩∘ | g f. ∃a b c. g : b ↦⇘ℭ⇙ c ∧ f : a ↦⇘ℭ⇙ b}"
then obtain g f a b c
where x_def: "x = [g, f]⇩∘" and "g : b ↦⇘ℭ⇙ c" and "f : a ↦⇘ℭ⇙ b"
by clarsimp
with vfsequence_vcpower_two_vpair show "x ∈⇩∘ ℭ⦇Arr⦈ ^⇩× 2⇩ℕ"
unfolding x_def by auto
qed
text‹Rules.›
lemma composable_arrsI[smc_cs_intros]:
assumes "gf = [g, f]⇩∘" and "g : b ↦⇘ℭ⇙ c" and "f : a ↦⇘ℭ⇙ b"
shows "gf ∈⇩∘ composable_arrs ℭ"
using assms(2,3) small_composable_arrs
unfolding assms(1) composable_arrs_def
by auto
lemma composable_arrsE[elim!]:
assumes "gf ∈⇩∘ composable_arrs ℭ"
obtains g f a b c where "gf = [g, f]⇩∘" and "g : b ↦⇘ℭ⇙ c" and "f : a ↦⇘ℭ⇙ b"
using assms small_composable_arrs unfolding composable_arrs_def by clarsimp
lemma small_composable_arrs'[simp]:
"small {[g, f]⇩∘ | g f. g ∈⇩∘ ℭ⦇Arr⦈ ∧ f ∈⇩∘ ℭ⦇Arr⦈ ∧ ℭ⦇Dom⦈⦇g⦈ = ℭ⦇Cod⦈⦇f⦈}"
proof(intro down[of _ ‹ℭ⦇Arr⦈ ^⇩× 2⇩ℕ›] subsetI)
fix gf assume
"gf ∈{[g, f]⇩∘ | g f. g ∈⇩∘ ℭ⦇Arr⦈ ∧ f ∈⇩∘ ℭ⦇Arr⦈ ∧ ℭ⦇Dom⦈⦇g⦈ = ℭ⦇Cod⦈⦇f⦈}"
then obtain g f
where gf_def: "gf = [g, f]⇩∘"
and "g ∈⇩∘ ℭ⦇Arr⦈"
and "f ∈⇩∘ ℭ⦇Arr⦈"
and "ℭ⦇Dom⦈⦇g⦈ = ℭ⦇Cod⦈⦇f⦈"
by clarsimp
with vfsequence_vcpower_two_vpair show "gf ∈⇩∘ ℭ⦇Arr⦈ ^⇩× 2⇩ℕ"
unfolding gf_def by auto
qed
lemma dg_composable_arrs':
"set {[g, f]⇩∘ | g f. g ∈⇩∘ ℭ⦇Arr⦈ ∧ f ∈⇩∘ ℭ⦇Arr⦈ ∧ ℭ⦇Dom⦈⦇g⦈ = ℭ⦇Cod⦈⦇f⦈} =
composable_arrs ℭ"
proof-
have "{[g, f]⇩∘ | g f. g ∈⇩∘ ℭ⦇Arr⦈ ∧ f ∈⇩∘ ℭ⦇Arr⦈ ∧ ℭ⦇Dom⦈⦇g⦈ = ℭ⦇Cod⦈⦇f⦈} =
{[g, f]⇩∘ | g f. ∃a b c. g : b ↦⇘ℭ⇙ c ∧ f : a ↦⇘ℭ⇙ b}"
proof(intro subset_antisym subsetI, unfold mem_Collect_eq; elim exE conjE)
fix gf g f
assume gf_def: "gf = [g, f]⇩∘"
and "g ∈⇩∘ ℭ⦇Arr⦈"
and "f ∈⇩∘ ℭ⦇Arr⦈"
and gf: "ℭ⦇Dom⦈⦇g⦈ = ℭ⦇Cod⦈⦇f⦈"
then obtain a b b' c where g: "g : b' ↦⇘ℭ⇙ c" and f: "f : a ↦⇘ℭ⇙ b"
by (auto intro!: is_arrI)
moreover have "b' = b"
unfolding is_arrD(2,3)[OF g, symmetric] is_arrD(2,3)[OF f, symmetric]
by (rule gf)
ultimately have "∃a b c. g : b ↦⇘ℭ⇙ c ∧ f : a ↦⇘ℭ⇙ b" by auto
then show "∃g f. gf = [g, f]⇩∘ ∧ (∃a b c. g : b ↦⇘ℭ⇙ c ∧ f : a ↦⇘ℭ⇙ b)"
unfolding gf_def by auto
next
fix gf g f a b c
assume gf_def: "gf = [g, f]⇩∘" and "g : b ↦⇘ℭ⇙ c" and "f : a ↦⇘ℭ⇙ b"
then have "g ∈⇩∘ ℭ⦇Arr⦈" "f ∈⇩∘ ℭ⦇Arr⦈" "ℭ⦇Dom⦈⦇g⦈ = ℭ⦇Cod⦈⦇f⦈" by auto
then show
"∃g f. gf = [g, f]⇩∘ ∧ g ∈⇩∘ ℭ⦇Arr⦈ ∧ f ∈⇩∘ ℭ⦇Arr⦈ ∧ ℭ⦇Dom⦈⦇g⦈ = ℭ⦇Cod⦈⦇f⦈"
unfolding gf_def by auto
qed
then show ?thesis unfolding composable_arrs_def by auto
qed
subsection‹Definition and elementary properties›
text‹
The definition of a semicategory that is used in this work is
similar to the definition that was used in \cite{mitchell_dominion_1972}.
It is also a natural generalization of the definition of a category that is
presented in Chapter I-2 in \cite{mac_lane_categories_2010}. The generalization
is performed by omitting the identity and the axioms associated
with it. The amendments to the definitions that are associated with size
have already been explained in the previous chapter.
›
locale semicategory = 𝒵 α + vfsequence ℭ + Comp: vsv ‹ℭ⦇Comp⦈› for α ℭ +
assumes smc_length[smc_cs_simps]: "vcard ℭ = 5⇩ℕ"
and smc_digraph[slicing_intros]: "digraph α (smc_dg ℭ)"
and smc_Comp_vdomain: "gf ∈⇩∘ 𝒟⇩∘ (ℭ⦇Comp⦈) ⟷
(∃g f b c a. gf = [g, f]⇩∘ ∧ g : b ↦⇘ℭ⇙ c ∧ f : a ↦⇘ℭ⇙ b)"
and smc_Comp_is_arr:
"⟦ g : b ↦⇘ℭ⇙ c; f : a ↦⇘ℭ⇙ b ⟧ ⟹ g ∘⇩A⇘ℭ⇙ f : a ↦⇘ℭ⇙ c"
and smc_Comp_assoc[smc_cs_simps]:
"⟦ h : c ↦⇘ℭ⇙ d; g : b ↦⇘ℭ⇙ c; f : a ↦⇘ℭ⇙ b ⟧ ⟹
(h ∘⇩A⇘ℭ⇙ g) ∘⇩A⇘ℭ⇙ f = h ∘⇩A⇘ℭ⇙ (g ∘⇩A⇘ℭ⇙ f)"
lemmas [smc_cs_simps] =
semicategory.smc_length
semicategory.smc_Comp_assoc
lemma (in semicategory) smc_Comp_is_arr'[smc_cs_intros]:
assumes "g : b ↦⇘ℭ⇙ c"
and "f : a ↦⇘ℭ⇙ b"
and "ℭ' = ℭ"
shows "g ∘⇩A⇘ℭ⇙ f : a ↦⇘ℭ'⇙ c"
using assms(1,2) unfolding assms(3) by (rule smc_Comp_is_arr)
lemmas [smc_cs_intros] =
semicategory.smc_Comp_is_arr'
semicategory.smc_Comp_is_arr
lemmas [slicing_intros] = semicategory.smc_digraph
text‹Rules.›
lemma (in semicategory) semicategory_axioms'[smc_cs_intros]:
assumes "α' = α"
shows "semicategory α' ℭ"
unfolding assms by (rule semicategory_axioms)
mk_ide rf semicategory_def[unfolded semicategory_axioms_def]
|intro semicategoryI|
|dest semicategoryD[dest]|
|elim semicategoryE[elim]|
lemma semicategoryI':
assumes "𝒵 α"
and "vfsequence ℭ"
and "vsv (ℭ⦇Comp⦈)"
and "vcard ℭ = 5⇩ℕ"
and "vsv (ℭ⦇Dom⦈)"
and "vsv (ℭ⦇Cod⦈)"
and "𝒟⇩∘ (ℭ⦇Dom⦈) = ℭ⦇Arr⦈"
and "ℛ⇩∘ (ℭ⦇Dom⦈) ⊆⇩∘ ℭ⦇Obj⦈"
and "𝒟⇩∘ (ℭ⦇Cod⦈) = ℭ⦇Arr⦈"
and "ℛ⇩∘ (ℭ⦇Cod⦈) ⊆⇩∘ ℭ⦇Obj⦈"
and "⋀gf. gf ∈⇩∘ 𝒟⇩∘ (ℭ⦇Comp⦈) ⟷
(∃g f b c a. gf = [g, f]⇩∘ ∧ g : b ↦⇘ℭ⇙ c ∧ f : a ↦⇘ℭ⇙ b)"
and "⋀b c g a f. ⟦ g : b ↦⇘ℭ⇙ c; f : a ↦⇘ℭ⇙ b ⟧ ⟹ g ∘⇩A⇘ℭ⇙ f : a ↦⇘ℭ⇙ c"
and "⋀c d h b g a f. ⟦ h : c ↦⇘ℭ⇙ d; g : b ↦⇘ℭ⇙ c; f : a ↦⇘ℭ⇙ b ⟧ ⟹
(h ∘⇩A⇘ℭ⇙ g) ∘⇩A⇘ℭ⇙ f = h ∘⇩A⇘ℭ⇙ (g ∘⇩A⇘ℭ⇙ f)"
and "ℭ⦇Obj⦈ ⊆⇩∘ Vset α"
and "⋀A B. ⟦ A ⊆⇩∘ ℭ⦇Obj⦈; B ⊆⇩∘ ℭ⦇Obj⦈; A ∈⇩∘ Vset α; B ∈⇩∘ Vset α ⟧ ⟹
(⋃⇩∘a∈⇩∘A. ⋃⇩∘b∈⇩∘B. Hom ℭ a b) ∈⇩∘ Vset α"
shows "semicategory α ℭ"
by (intro semicategoryI digraphI, unfold slicing_simps)
(simp_all add: assms nat_omega_simps smc_dg_def)
lemma semicategoryD':
assumes "semicategory α ℭ"
shows "𝒵 α"
and "vfsequence ℭ"
and "vsv (ℭ⦇Comp⦈)"
and "vcard ℭ = 5⇩ℕ"
and "vsv (ℭ⦇Dom⦈)"
and "vsv (ℭ⦇Cod⦈)"
and "𝒟⇩∘ (ℭ⦇Dom⦈) = ℭ⦇Arr⦈"
and "ℛ⇩∘ (ℭ⦇Dom⦈) ⊆⇩∘ ℭ⦇Obj⦈"
and "𝒟⇩∘ (ℭ⦇Cod⦈) = ℭ⦇Arr⦈"
and "ℛ⇩∘ (ℭ⦇Cod⦈) ⊆⇩∘ ℭ⦇Obj⦈"
and "⋀gf. gf ∈⇩∘ 𝒟⇩∘ (ℭ⦇Comp⦈) ⟷
(∃g f b c a. gf = [g, f]⇩∘ ∧ g : b ↦⇘ℭ⇙ c ∧ f : a ↦⇘ℭ⇙ b)"
and "⋀b c g a f. ⟦ g : b ↦⇘ℭ⇙ c; f : a ↦⇘ℭ⇙ b ⟧ ⟹ g ∘⇩A⇘ℭ⇙ f : a ↦⇘ℭ⇙ c"
and "⋀c d h b g a f. ⟦ h : c ↦⇘ℭ⇙ d; g : b ↦⇘ℭ⇙ c; f : a ↦⇘ℭ⇙ b ⟧ ⟹
(h ∘⇩A⇘ℭ⇙ g) ∘⇩A⇘ℭ⇙ f = h ∘⇩A⇘ℭ⇙ (g ∘⇩A⇘ℭ⇙ f)"
and "ℭ⦇Obj⦈ ⊆⇩∘ Vset α"
and "⋀A B. ⟦ A ⊆⇩∘ ℭ⦇Obj⦈; B ⊆⇩∘ ℭ⦇Obj⦈; A ∈⇩∘ Vset α; B ∈⇩∘ Vset α ⟧ ⟹
(⋃⇩∘a∈⇩∘A. ⋃⇩∘b∈⇩∘B. Hom ℭ a b) ∈⇩∘ Vset α"
by
(
simp_all add:
semicategoryD(2-8)[OF assms]
digraphD[OF semicategoryD(5)[OF assms], unfolded slicing_simps]
)
lemma semicategoryE':
assumes "semicategory α ℭ"
obtains "𝒵 α"
and "vfsequence ℭ"
and "vsv (ℭ⦇Comp⦈)"
and "vcard ℭ = 5⇩ℕ"
and "vsv (ℭ⦇Dom⦈)"
and "vsv (ℭ⦇Cod⦈)"
and "𝒟⇩∘ (ℭ⦇Dom⦈) = ℭ⦇Arr⦈"
and "ℛ⇩∘ (ℭ⦇Dom⦈) ⊆⇩∘ ℭ⦇Obj⦈"
and "𝒟⇩∘ (ℭ⦇Cod⦈) = ℭ⦇Arr⦈"
and "ℛ⇩∘ (ℭ⦇Cod⦈) ⊆⇩∘ ℭ⦇Obj⦈"
and "⋀gf. gf ∈⇩∘ 𝒟⇩∘ (ℭ⦇Comp⦈) ⟷
(∃g f b c a. gf = [g, f]⇩∘ ∧ g : b ↦⇘ℭ⇙ c ∧ f : a ↦⇘ℭ⇙ b)"
and "⋀b c g a f. ⟦ g : b ↦⇘ℭ⇙ c; f : a ↦⇘ℭ⇙ b ⟧ ⟹ g ∘⇩A⇘ℭ⇙ f : a ↦⇘ℭ⇙ c"
and "⋀c d h b g a f. ⟦ h : c ↦⇘ℭ⇙ d; g : b ↦⇘ℭ⇙ c; f : a ↦⇘ℭ⇙ b ⟧ ⟹
(h ∘⇩A⇘ℭ⇙ g) ∘⇩A⇘ℭ⇙ f = h ∘⇩A⇘ℭ⇙ (g ∘⇩A⇘ℭ⇙ f)"
and "ℭ⦇Obj⦈ ⊆⇩∘ Vset α"
and "⋀A B. ⟦ A ⊆⇩∘ ℭ⦇Obj⦈; B ⊆⇩∘ ℭ⦇Obj⦈; A ∈⇩∘ Vset α; B ∈⇩∘ Vset α ⟧ ⟹
(⋃⇩∘a∈⇩∘A. ⋃⇩∘b∈⇩∘B. Hom ℭ a b) ∈⇩∘ Vset α"
using assms by (simp add: semicategoryD')
text‹
While using the sublocale infrastructure in conjunction with the rewrite
morphisms is plausible for achieving automation of slicing, this approach
has certain limitations. For example, the rewrite morphisms cannot be added to a
given interpretation that was achieved using the
command @{command sublocale}\footnote{
\url{
https://lists.cam.ac.uk/pipermail/cl-isabelle-users/2019-September/msg00074.html
}
}.
Thus, instead of using a partial solution based on the command
@{command sublocale}, the rewriting is performed manually for
selected theorems. However, it is hoped that better automation will be provided
in the future.
›
context semicategory
begin
interpretation dg: digraph α ‹smc_dg ℭ› by (rule smc_digraph)
sublocale Dom: vsv ‹ℭ⦇Dom⦈› by (rule dg.Dom.vsv_axioms[unfolded slicing_simps])
sublocale Cod: vsv ‹ℭ⦇Cod⦈› by (rule dg.Cod.vsv_axioms[unfolded slicing_simps])
lemmas_with [unfolded slicing_simps]:
smc_Dom_vdomain[smc_cs_simps] = dg.dg_Dom_vdomain
and smc_Dom_vrange = dg.dg_Dom_vrange
and smc_Cod_vdomain[smc_cs_simps] = dg.dg_Cod_vdomain
and smc_Cod_vrange = dg.dg_Cod_vrange
and smc_Obj_vsubset_Vset = dg.dg_Obj_vsubset_Vset
and smc_Hom_vifunion_in_Vset[smc_cs_intros] = dg.dg_Hom_vifunion_in_Vset
and smc_Obj_if_Dom_vrange = dg.dg_Obj_if_Dom_vrange
and smc_Obj_if_Cod_vrange = dg.dg_Obj_if_Cod_vrange
and smc_is_arrD = dg.dg_is_arrD
and smc_is_arrE[elim] = dg.dg_is_arrE
and smc_in_ArrE[elim] = dg.dg_in_ArrE
and smc_Hom_in_Vset[smc_cs_intros] = dg.dg_Hom_in_Vset
and smc_Arr_vsubset_Vset = dg.dg_Arr_vsubset_Vset
and smc_Dom_vsubset_Vset = dg.dg_Dom_vsubset_Vset
and smc_Cod_vsubset_Vset = dg.dg_Cod_vsubset_Vset
and smc_Obj_in_Vset = dg.dg_Obj_in_Vset
and smc_in_Obj_in_Vset[smc_cs_intros] = dg.dg_in_Obj_in_Vset
and smc_Arr_in_Vset = dg.dg_Arr_in_Vset
and smc_in_Arr_in_Vset[smc_cs_intros] = dg.dg_in_Arr_in_Vset
and smc_Dom_in_Vset = dg.dg_Dom_in_Vset
and smc_Cod_in_Vset = dg.dg_Cod_in_Vset
and smc_digraph_if_ge_Limit = dg.dg_digraph_if_ge_Limit
and smc_Dom_app_in_Obj = dg.dg_Dom_app_in_Obj
and smc_Cod_app_in_Obj = dg.dg_Cod_app_in_Obj
and smc_Arr_vempty_if_Obj_vempty = dg.dg_Arr_vempty_if_Obj_vempty
and smc_Dom_vempty_if_Arr_vempty = dg.dg_Dom_vempty_if_Arr_vempty
and smc_Cod_vempty_if_Arr_vempty = dg.dg_Cod_vempty_if_Arr_vempty
end
lemmas [smc_cs_intros] =
semicategory.smc_is_arrD(1-3)
semicategory.smc_Hom_in_Vset
text‹Elementary properties.›
lemma smc_eqI:
assumes "semicategory α 𝔄"
and "semicategory α 𝔅"
and "𝔄⦇Obj⦈ = 𝔅⦇Obj⦈"
and "𝔄⦇Arr⦈ = 𝔅⦇Arr⦈"
and "𝔄⦇Dom⦈ = 𝔅⦇Dom⦈"
and "𝔄⦇Cod⦈ = 𝔅⦇Cod⦈"
and "𝔄⦇Comp⦈ = 𝔅⦇Comp⦈"
shows "𝔄 = 𝔅"
proof-
interpret 𝔄: semicategory α 𝔄 by (rule assms(1))
interpret 𝔅: semicategory α 𝔅 by (rule assms(2))
show ?thesis
proof(rule vsv_eqI)
have dom: "𝒟⇩∘ 𝔄 = 5⇩ℕ" by (cs_concl cs_simp: smc_cs_simps V_cs_simps)
show "𝒟⇩∘ 𝔄 = 𝒟⇩∘ 𝔅" by (cs_concl cs_simp: dom smc_cs_simps V_cs_simps)
show "a ∈⇩∘ 𝒟⇩∘ 𝔄 ⟹ 𝔄⦇a⦈ = 𝔅⦇a⦈" for a
by (unfold dom, elim_in_numeral, insert assms) (auto simp: dg_field_simps)
qed auto
qed
lemma smc_dg_eqI:
assumes "semicategory α 𝔄"
and "semicategory α 𝔅"
and "𝔄⦇Comp⦈ = 𝔅⦇Comp⦈"
and "smc_dg 𝔄 = smc_dg 𝔅"
shows "𝔄 = 𝔅"
proof(rule smc_eqI)
from assms(4) have
"smc_dg 𝔄⦇Obj⦈ = smc_dg 𝔅⦇Obj⦈"
"smc_dg 𝔄⦇Arr⦈ = smc_dg 𝔅⦇Arr⦈"
"smc_dg 𝔄⦇Dom⦈ = smc_dg 𝔅⦇Dom⦈"
"smc_dg 𝔄⦇Cod⦈ = smc_dg 𝔅⦇Cod⦈"
by auto
then show
"𝔄⦇Obj⦈ = 𝔅⦇Obj⦈" "𝔄⦇Arr⦈ = 𝔅⦇Arr⦈" "𝔄⦇Dom⦈ = 𝔅⦇Dom⦈" "𝔄⦇Cod⦈ = 𝔅⦇Cod⦈"
unfolding slicing_simps by simp_all
qed (auto intro: assms)
lemma (in semicategory) smc_def: "ℭ = [ℭ⦇Obj⦈, ℭ⦇Arr⦈, ℭ⦇Dom⦈, ℭ⦇Cod⦈, ℭ⦇Comp⦈]⇩∘"
proof(rule vsv_eqI)
have dom_lhs: "𝒟⇩∘ ℭ = 5⇩ℕ" by (cs_concl cs_simp: smc_cs_simps V_cs_simps)
have dom_rhs: "𝒟⇩∘ [ℭ⦇Obj⦈, ℭ⦇Arr⦈, ℭ⦇Dom⦈, ℭ⦇Cod⦈, ℭ⦇Comp⦈]⇩∘ = 5⇩ℕ"
by (simp add: nat_omega_simps)
then show "𝒟⇩∘ ℭ = 𝒟⇩∘ [ℭ⦇Obj⦈, ℭ⦇Arr⦈, ℭ⦇Dom⦈, ℭ⦇Cod⦈, ℭ⦇Comp⦈]⇩∘"
unfolding dom_lhs dom_rhs by simp
show "a ∈⇩∘ 𝒟⇩∘ ℭ ⟹ ℭ⦇a⦈ = [ℭ⦇Obj⦈, ℭ⦇Arr⦈, ℭ⦇Dom⦈, ℭ⦇Cod⦈, ℭ⦇Comp⦈]⇩∘⦇a⦈"
for a
unfolding dom_lhs
by elim_in_numeral (simp_all add: dg_field_simps nat_omega_simps)
qed auto
lemma (in semicategory) smc_Comp_vdomainI[smc_cs_intros]:
assumes "g : b ↦⇘ℭ⇙ c" and "f : a ↦⇘ℭ⇙ b" and "gf = [g, f]⇩∘"
shows "gf ∈⇩∘ 𝒟⇩∘ (ℭ⦇Comp⦈)"
using assms by (intro smc_Comp_vdomain[THEN iffD2]) auto
lemmas [smc_cs_intros] = semicategory.smc_Comp_vdomainI
lemma (in semicategory) smc_Comp_vdomainE[elim!]:
assumes "gf ∈⇩∘ 𝒟⇩∘ (ℭ⦇Comp⦈)"
obtains g f a b c where "gf = [g, f]⇩∘" and "g : b ↦⇘ℭ⇙ c" and "f : a ↦⇘ℭ⇙ b"
proof-
from smc_Comp_vdomain[THEN iffD1, OF assms(1)] obtain g f b c a
where "gf = [g, f]⇩∘" and "g : b ↦⇘ℭ⇙ c" and "f : a ↦⇘ℭ⇙ b"
by clarsimp
with that show ?thesis by simp
qed
lemma (in semicategory) smc_Comp_vdomain_is_composable_arrs:
"𝒟⇩∘ (ℭ⦇Comp⦈) = composable_arrs ℭ"
by (intro vsubset_antisym vsubsetI) (auto intro!: smc_cs_intros)+
lemma (in semicategory) smc_Comp_vrange: "ℛ⇩∘ (ℭ⦇Comp⦈) ⊆⇩∘ ℭ⦇Arr⦈"
proof(rule Comp.vsv_vrange_vsubset)
fix gf assume "gf ∈⇩∘ 𝒟⇩∘ (ℭ⦇Comp⦈)"
from smc_Comp_vdomain[THEN iffD1, OF this] obtain g f b c a
where gf_def: "gf = [g, f]⇩∘"
and g: "g : b ↦⇘ℭ⇙ c"
and f: "f : a ↦⇘ℭ⇙ b"
by clarsimp
from semicategory_axioms g f show "ℭ⦇Comp⦈⦇gf⦈ ∈⇩∘ ℭ⦇Arr⦈"
by (cs_concl cs_simp: gf_def smc_cs_simps cs_intro: smc_cs_intros)
qed
sublocale semicategory ⊆ Comp: pbinop ‹ℭ⦇Arr⦈› ‹ℭ⦇Comp⦈›
proof unfold_locales
show "𝒟⇩∘ (ℭ⦇Comp⦈) ⊆⇩∘ ℭ⦇Arr⦈ ^⇩× 2⇩ℕ"
proof(intro vsubsetI; unfold smc_Comp_vdomain)
fix gf assume "∃g f b c a. gf = [g, f]⇩∘ ∧ g : b ↦⇘ℭ⇙ c ∧ f : a ↦⇘ℭ⇙ b"
then obtain a b c g f
where x_def: "gf = [g, f]⇩∘" and "g : b ↦⇘ℭ⇙ c" and "f : a ↦⇘ℭ⇙ b"
by auto
then have "g ∈⇩∘ ℭ⦇Arr⦈" "f ∈⇩∘ ℭ⦇Arr⦈" by auto
then show "gf ∈⇩∘ ℭ⦇Arr⦈ ^⇩× 2⇩ℕ"
unfolding x_def by (auto simp: nat_omega_simps)
qed
show "ℛ⇩∘ (ℭ⦇Comp⦈) ⊆⇩∘ ℭ⦇Arr⦈" by (rule smc_Comp_vrange)
qed auto
text‹Size.›
lemma (in semicategory) smc_Comp_vsubset_Vset: "ℭ⦇Comp⦈ ⊆⇩∘ Vset α"
proof(intro vsubsetI)
fix gfh assume "gfh ∈⇩∘ ℭ⦇Comp⦈"
then obtain gf h
where gfh_def: "gfh = ⟨gf, h⟩"
and gf: "gf ∈⇩∘ 𝒟⇩∘ (ℭ⦇Comp⦈)"
and h: "h ∈⇩∘ ℛ⇩∘ (ℭ⦇Comp⦈)"
by (blast elim: Comp.vbrelation_vinE)
from gf obtain g f a b c
where gf_def: "gf = [g, f]⇩∘" and g: "g : b ↦⇘ℭ⇙ c" and f: "f : a ↦⇘ℭ⇙ b"
by clarsimp
from h smc_Comp_vrange have "h ∈⇩∘ ℭ⦇Arr⦈" by auto
with g f show "gfh ∈⇩∘ Vset α"
unfolding gfh_def gf_def
by (cs_concl cs_intro: smc_cs_intros V_cs_intros)
qed
lemma (in semicategory) smc_semicategory_in_Vset_4: "ℭ ∈⇩∘ Vset (α + 4⇩ℕ)"
proof-
note [folded VPow_iff, folded Vset_succ[OF Ord_α], smc_cs_intros] =
smc_Obj_vsubset_Vset
smc_Arr_vsubset_Vset
smc_Dom_vsubset_Vset
smc_Cod_vsubset_Vset
smc_Comp_vsubset_Vset
show ?thesis
by (subst smc_def, succ_of_numeral)
(
cs_concl
cs_simp: plus_V_succ_right V_cs_simps
cs_intro: smc_cs_intros V_cs_intros
)
qed
lemma (in semicategory) smc_Comp_in_Vset:
assumes "𝒵 β" and "α ∈⇩∘ β"
shows "ℭ⦇Comp⦈ ∈⇩∘ Vset β"
using smc_Comp_vsubset_Vset by (meson Vset_in_mono assms(2) vsubset_in_VsetI)
lemma (in semicategory) smc_in_Vset:
assumes "𝒵 β" and "α ∈⇩∘ β"
shows "ℭ ∈⇩∘ Vset β"
proof-
interpret β: 𝒵 β by (rule assms(1))
note [smc_cs_intros] =
smc_Obj_in_Vset
smc_Arr_in_Vset
smc_Dom_in_Vset
smc_Cod_in_Vset
smc_Comp_in_Vset
from assms(2) show ?thesis
by (subst smc_def) (cs_concl cs_intro: smc_cs_intros V_cs_intros)
qed
lemma (in semicategory) smc_semicategory_if_ge_Limit:
assumes "𝒵 β" and "α ∈⇩∘ β"
shows "semicategory β ℭ"
by (rule semicategoryI)
(
auto
intro: smc_cs_intros
simp: smc_cs_simps assms vfsequence_axioms smc_digraph_if_ge_Limit
)
lemma small_semicategory[simp]: "small {ℭ. semicategory α ℭ}"
proof(cases ‹𝒵 α›)
case True
from semicategory.smc_in_Vset[of α] show ?thesis
by (intro down[of _ ‹Vset (α + ω)›])
(auto simp: True 𝒵.𝒵_Limit_αω 𝒵.𝒵_ω_αω 𝒵.intro 𝒵.𝒵_α_αω)
next
case False
then have "{ℭ. semicategory α ℭ} = {}" by auto
then show ?thesis by simp
qed
lemma (in 𝒵) semicategories_in_Vset:
assumes "𝒵 β" and "α ∈⇩∘ β"
shows "set {ℭ. semicategory α ℭ} ∈⇩∘ Vset β"
proof(rule vsubset_in_VsetI)
interpret β: 𝒵 β by (rule assms(1))
show "set {ℭ. semicategory α ℭ} ⊆⇩∘ Vset (α + 4⇩ℕ)"
proof(intro vsubsetI)
fix ℭ assume prems: "ℭ ∈⇩∘ set {ℭ. semicategory α ℭ}"
interpret semicategory α ℭ using prems by simp
show "ℭ ∈⇩∘ Vset (α + 4⇩ℕ)"
unfolding VPow_iff by (rule smc_semicategory_in_Vset_4)
qed
from assms(2) show "Vset (α + 4⇩ℕ) ∈⇩∘ Vset β"
by (cs_concl cs_intro: V_cs_intros Ord_cs_intros)
qed
lemma semicategory_if_semicategory:
assumes "semicategory β ℭ"
and "𝒵 α"
and "ℭ⦇Obj⦈ ⊆⇩∘ Vset α"
and "⋀A B. ⟦ A ⊆⇩∘ ℭ⦇Obj⦈; B ⊆⇩∘ ℭ⦇Obj⦈; A ∈⇩∘ Vset α; B ∈⇩∘ Vset α ⟧ ⟹
(⋃⇩∘a∈⇩∘A. ⋃⇩∘b∈⇩∘B. Hom ℭ a b) ∈⇩∘ Vset α"
shows "semicategory α ℭ"
proof-
interpret semicategory β ℭ by (rule assms(1))
interpret α: 𝒵 α by (rule assms(2))
show ?thesis
proof(intro semicategoryI)
show "vfsequence ℭ" by (simp add: vfsequence_axioms)
show "digraph α (smc_dg ℭ)"
by (rule digraph_if_digraph, unfold slicing_simps)
(auto intro!: assms(1,3,4) slicing_intros)
qed (auto intro: smc_cs_intros simp: smc_cs_simps)
qed
text‹Further elementary properties.›
lemma (in semicategory) smc_Comp_vempty_if_Arr_vempty:
assumes "ℭ⦇Arr⦈ = 0"
shows "ℭ⦇Comp⦈ = 0"
using assms smc_Comp_vrange by (auto intro: Comp.vsv_vrange_vempty)
subsection‹Opposite semicategory›
subsubsection‹Definition and elementary properties›
text‹See Chapter II-2 in \cite{mac_lane_categories_2010}.›
definition op_smc :: "V ⇒ V"
where "op_smc ℭ = [ℭ⦇Obj⦈, ℭ⦇Arr⦈, ℭ⦇Cod⦈, ℭ⦇Dom⦈, fflip (ℭ⦇Comp⦈)]⇩∘"
text‹Components.›
lemma op_smc_components:
shows [smc_op_simps]: "op_smc ℭ⦇Obj⦈ = ℭ⦇Obj⦈"
and [smc_op_simps]: "op_smc ℭ⦇Arr⦈ = ℭ⦇Arr⦈"
and [smc_op_simps]: "op_smc ℭ⦇Dom⦈ = ℭ⦇Cod⦈"
and [smc_op_simps]: "op_smc ℭ⦇Cod⦈ = ℭ⦇Dom⦈"
and "op_smc ℭ⦇Comp⦈ = fflip (ℭ⦇Comp⦈)"
unfolding op_smc_def dg_field_simps by (auto simp: nat_omega_simps)
lemma op_smc_component_intros[smc_op_intros]:
shows "a ∈⇩∘ ℭ⦇Obj⦈ ⟹ a ∈⇩∘ op_smc ℭ⦇Obj⦈"
and "f ∈⇩∘ ℭ⦇Arr⦈ ⟹ f ∈⇩∘ op_smc ℭ⦇Arr⦈"
unfolding smc_op_simps by simp_all
text‹Slicing.›
lemma op_dg_smc_dg[slicing_commute]: "op_dg (smc_dg ℭ) = smc_dg (op_smc ℭ)"
unfolding smc_dg_def op_smc_def op_dg_def dg_field_simps
by (simp add: nat_omega_simps)
text‹Regular definitions.›
lemma op_smc_Comp_vdomain[smc_op_simps]:
"𝒟⇩∘ (op_smc ℭ⦇Comp⦈) = (𝒟⇩∘ (ℭ⦇Comp⦈))¯⇩∙"
unfolding op_smc_components by simp
lemma op_smc_is_arr[smc_op_simps]: "f : b ↦⇘op_smc ℭ⇙ a ⟷ f : a ↦⇘ℭ⇙ b"
unfolding smc_op_simps is_arr_def by auto
lemmas [smc_op_intros] = op_smc_is_arr[THEN iffD2]
lemma (in semicategory) op_smc_Comp_vrange[smc_op_simps]:
"ℛ⇩∘ (op_smc ℭ⦇Comp⦈) = ℛ⇩∘ (ℭ⦇Comp⦈)"
using Comp.vrange_fflip unfolding op_smc_components by simp
lemmas [smc_op_simps] = semicategory.op_smc_Comp_vrange
lemma (in semicategory) op_smc_Comp[smc_op_simps]:
assumes "f : b ↦⇘ℭ⇙ c" and "g : a ↦⇘ℭ⇙ b"
shows "g ∘⇩A⇘op_smc ℭ⇙ f = f ∘⇩A⇘ℭ⇙ g"
using assms
unfolding op_smc_components
by (auto intro!: fflip_app smc_cs_intros)
lemmas [smc_op_simps] = semicategory.op_smc_Comp
lemma op_smc_Hom[smc_op_simps]: "Hom (op_smc ℭ) a b = Hom ℭ b a"
unfolding smc_op_simps by simp
subsubsection‹Further properties›
lemma (in semicategory) semicategory_op[smc_op_intros]:
"semicategory α (op_smc ℭ)"
proof(intro semicategoryI)
from semicategory_axioms smc_digraph show "digraph α (smc_dg (op_smc ℭ))"
by (cs_concl cs_simp: slicing_commute[symmetric] cs_intro: dg_op_intros)
show "vfsequence (op_smc ℭ)" unfolding op_smc_def by simp
show "vcard (op_smc ℭ) = 5⇩ℕ"
unfolding op_smc_def by (simp add: nat_omega_simps)
show "(gf ∈⇩∘ 𝒟⇩∘ (op_smc ℭ⦇Comp⦈)) ⟷
(∃g f b c a. gf = [g, f]⇩∘ ∧ g : b ↦⇘op_smc ℭ⇙ c ∧ f : a ↦⇘op_smc ℭ⇙ b)"
for gf
proof(rule iffI; unfold smc_op_simps)
assume prems: "gf ∈⇩∘ (𝒟⇩∘ (ℭ⦇Comp⦈))¯⇩∙"
then obtain g' f' where gf_def: "gf = [g', f']⇩∘" by clarsimp
with prems have "[f', g']⇩∘ ∈⇩∘ 𝒟⇩∘ (ℭ⦇Comp⦈)" by (auto intro: smc_cs_intros)
with smc_Comp_vdomain show
"∃g f b c a. gf = [g, f]⇩∘ ∧ g : c ↦⇘ℭ⇙ b ∧ f : b ↦⇘ℭ⇙ a"
unfolding gf_def by auto
next
assume "∃g f b c a. gf = [g, f]⇩∘ ∧ g : c ↦⇘ℭ⇙ b ∧ f : b ↦⇘ℭ⇙ a"
then obtain g f b c a
where gf_def: "gf = [g, f]⇩∘" and g: "g : c ↦⇘ℭ⇙ b" and f: "f : b ↦⇘ℭ⇙ a"
by clarsimp
then have "g ∈⇩∘ ℭ⦇Arr⦈" and "f ∈⇩∘ ℭ⦇Arr⦈" by force+
from g f have "[f, g]⇩∘ ∈⇩∘ 𝒟⇩∘ (ℭ⦇Comp⦈)"
unfolding gf_def by (intro smc_Comp_vdomainI) auto
then show "gf ∈⇩∘ (𝒟⇩∘ (ℭ⦇Comp⦈))¯⇩∙"
unfolding gf_def by (auto intro: smc_cs_intros)
qed
from semicategory_axioms show
"⟦ g : b ↦⇘op_smc ℭ⇙ c; f : a ↦⇘op_smc ℭ⇙ b ⟧ ⟹
g ∘⇩A⇘op_smc ℭ⇙ f : a ↦⇘op_smc ℭ⇙ c"
for g b c f a
unfolding smc_op_simps
by (cs_concl cs_simp: smc_op_simps cs_intro: smc_cs_intros)
fix h c d g b f a
assume "h : c ↦⇘op_smc ℭ⇙ d" "g : b ↦⇘op_smc ℭ⇙ c" "f : a ↦⇘op_smc ℭ⇙ b"
with semicategory_axioms show
"(h ∘⇩A⇘op_smc ℭ⇙ g) ∘⇩A⇘op_smc ℭ⇙ f = h ∘⇩A⇘op_smc ℭ⇙ (g ∘⇩A⇘op_smc ℭ⇙ f)"
unfolding smc_op_simps
by (cs_concl cs_simp: smc_op_simps smc_cs_simps cs_intro: smc_cs_intros)
qed (auto simp: fflip_vsv op_smc_components(5))
lemmas semicategory_op[smc_op_intros] = semicategory.semicategory_op
lemma (in semicategory) smc_op_smc_op_smc[smc_op_simps]: "op_smc (op_smc ℭ) = ℭ"
by (rule smc_eqI, unfold smc_op_simps op_smc_components)
(
auto simp:
Comp.pbinop_fflip_fflip
semicategory_axioms
semicategory.semicategory_op semicategory_op
intro: smc_cs_intros
)
lemmas smc_op_smc_op_smc[smc_op_simps] = semicategory.smc_op_smc_op_smc
lemma eq_op_smc_iff[smc_op_simps]:
assumes "semicategory α 𝔄" and "semicategory α 𝔅"
shows "op_smc 𝔄 = op_smc 𝔅 ⟷ 𝔄 = 𝔅"
proof
interpret 𝔄: semicategory α 𝔄 by (rule assms(1))
interpret 𝔅: semicategory α 𝔅 by (rule assms(2))
assume prems: "op_smc 𝔄 = op_smc 𝔅" show "𝔄 = 𝔅"
proof(rule smc_eqI)
show
"𝔄⦇Obj⦈ = 𝔅⦇Obj⦈"
"𝔄⦇Arr⦈ = 𝔅⦇Arr⦈"
"𝔄⦇Dom⦈ = 𝔅⦇Dom⦈"
"𝔄⦇Cod⦈ = 𝔅⦇Cod⦈"
"𝔄⦇Comp⦈ = 𝔅⦇Comp⦈"
by (metis prems 𝔄.smc_op_smc_op_smc 𝔅.smc_op_smc_op_smc)+
qed (auto intro: assms)
qed auto
subsection‹Arrow with a domain and a codomain›
lemma (in semicategory) smc_assoc_helper:
assumes "f : a ↦⇘ℭ⇙ b"
and "g : b ↦⇘ℭ⇙ c"
and "h : c ↦⇘ℭ⇙ d"
and "q : b ↦⇘ℭ⇙ d"
and "h ∘⇩A⇘ℭ⇙ g = q"
shows "h ∘⇩A⇘ℭ⇙ (g ∘⇩A⇘ℭ⇙ f) = q ∘⇩A⇘ℭ⇙ f"
using semicategory_axioms assms(1-4)
by (cs_concl cs_simp: semicategory.smc_Comp_assoc[symmetric] assms(5))
lemma (in semicategory) smc_pattern_rectangle_right:
assumes "aa' : a ↦⇘ℭ⇙ a'"
and "a'a'' : a' ↦⇘ℭ⇙ a''"
and "a''b'' : a'' ↦⇘ℭ⇙ b''"
and "ab : a ↦⇘ℭ⇙ b"
and "bb' : b ↦⇘ℭ⇙ b'"
and "b'b'' : b' ↦⇘ℭ⇙ b''"
and "a'b' : a' ↦⇘ℭ⇙ b'"
and "a'b' ∘⇩A⇘ℭ⇙ aa' = bb' ∘⇩A⇘ℭ⇙ ab"
and "b'b'' ∘⇩A⇘ℭ⇙ a'b' = a''b'' ∘⇩A⇘ℭ⇙ a'a''"
shows "a''b'' ∘⇩A⇘ℭ⇙ (a'a'' ∘⇩A⇘ℭ⇙ aa') = (b'b'' ∘⇩A⇘ℭ⇙ bb') ∘⇩A⇘ℭ⇙ ab"
proof-
from semicategory_axioms assms(3,2,1) have
"a''b'' ∘⇩A⇘ℭ⇙ (a'a'' ∘⇩A⇘ℭ⇙ aa') = (a''b'' ∘⇩A⇘ℭ⇙ a'a'') ∘⇩A⇘ℭ⇙ aa'"
by (cs_concl cs_simp: smc_cs_simps cs_intro: smc_cs_intros)
also have "… = (b'b'' ∘⇩A⇘ℭ⇙ a'b') ∘⇩A⇘ℭ⇙ aa'" unfolding assms(9) ..
also from semicategory_axioms assms(1,6,7) have
"… = b'b'' ∘⇩A⇘ℭ⇙ (a'b' ∘⇩A⇘ℭ⇙ aa')"
by (cs_concl cs_simp: smc_cs_simps cs_intro: smc_cs_intros)
also have "… = b'b'' ∘⇩A⇘ℭ⇙ (bb' ∘⇩A⇘ℭ⇙ ab)" unfolding assms(8) ..
also from semicategory_axioms assms(6,5,4) have
"… = (b'b'' ∘⇩A⇘ℭ⇙ bb') ∘⇩A⇘ℭ⇙ ab"
by (cs_concl cs_simp: smc_cs_simps cs_intro: smc_cs_intros)
finally show ?thesis by simp
qed
lemmas (in semicategory) smc_pattern_rectangle_left =
smc_pattern_rectangle_right[symmetric]
subsection‹Monic arrow and epic arrow›
text‹See Chapter I-5 in \cite{mac_lane_categories_2010}.›
definition is_monic_arr :: "V ⇒ V ⇒ V ⇒ V ⇒ bool"
where "is_monic_arr ℭ b c m ⟷
m : b ↦⇘ℭ⇙ c ∧
(
∀f g a.
f : a ↦⇘ℭ⇙ b ⟶ g : a ↦⇘ℭ⇙ b ⟶ m ∘⇩A⇘ℭ⇙ f = m ∘⇩A⇘ℭ⇙ g ⟶ f = g
)"
syntax "_is_monic_arr" :: "V ⇒ V ⇒ V ⇒ V ⇒ bool"
(‹_ : _ ↦⇩m⇩o⇩nı _› [51, 51, 51] 51)
translations "m : b ↦⇩m⇩o⇩n⇘ℭ⇙ c" ⇌ "CONST is_monic_arr ℭ b c m"
definition is_epic_arr :: "V ⇒ V ⇒ V ⇒ V ⇒ bool"
where "is_epic_arr ℭ a b e ≡ e : b ↦⇩m⇩o⇩n⇘op_smc ℭ⇙ a"
syntax "_is_epic_arr" :: "V ⇒ V ⇒ V ⇒ V ⇒ bool"
(‹_ : _ ↦⇩e⇩p⇩iı _› [51, 51, 51] 51)
translations "e : a ↦⇩e⇩p⇩i⇘ℭ⇙ b" ⇌ "CONST is_epic_arr ℭ a b e"
text‹Rules.›
mk_ide rf is_monic_arr_def
|intro is_monic_arrI|
|dest is_monic_arrD[dest]|
|elim is_monic_arrE[elim!]|
lemmas [smc_arrow_cs_intros] = is_monic_arrD(1)
lemma (in semicategory) is_epic_arrI:
assumes "e : a ↦⇘ℭ⇙ b"
and "⋀f g c. ⟦ f : b ↦⇘ℭ⇙ c; g : b ↦⇘ℭ⇙ c; f ∘⇩A⇘ℭ⇙ e = g ∘⇩A⇘ℭ⇙ e ⟧ ⟹
f = g"
shows "e : a ↦⇩e⇩p⇩i⇘ℭ⇙ b"
unfolding is_epic_arr_def
proof(intro is_monic_arrI, unfold smc_op_simps)
fix f g a
assume prems:
"f : b ↦⇘ℭ⇙ a" "g : b ↦⇘ℭ⇙ a" "e ∘⇩A⇘op_smc ℭ⇙ f = e ∘⇩A⇘op_smc ℭ⇙ g"
show "f = g"
proof-
from prems(3,1,2) assms(1) semicategory_axioms have "g ∘⇩A⇘ℭ⇙ e = f ∘⇩A⇘ℭ⇙ e"
by
(
cs_prems
cs_simp: smc_cs_simps smc_op_simps
cs_intro: smc_cs_intros smc_op_intros
)
simp
from assms(2)[OF prems(2,1) this] show ?thesis ..
qed
qed (rule assms(1))
lemma is_epic_arr_is_arr[smc_arrow_cs_intros, dest]:
assumes "e : a ↦⇩e⇩p⇩i⇘ℭ⇙ b"
shows "e : a ↦⇘ℭ⇙ b"
using assms unfolding is_epic_arr_def is_monic_arr_def smc_op_simps by simp
lemma (in semicategory) is_epic_arrD[dest]:
assumes "e : a ↦⇩e⇩p⇩i⇘ℭ⇙ b"
shows "e : a ↦⇘ℭ⇙ b"
and "⋀f g c. ⟦ f : b ↦⇘ℭ⇙ c; g : b ↦⇘ℭ⇙ c; f ∘⇩A⇘ℭ⇙ e = g ∘⇩A⇘ℭ⇙ e ⟧ ⟹
f = g"
proof-
note is_monic_arrD =
assms(1)[unfolded is_epic_arr_def is_monic_arr_def smc_op_simps]
from is_monic_arrD[THEN conjunct1] show e: "e : a ↦⇘ℭ⇙ b" by simp
fix f g c
assume prems: "f : b ↦⇘ℭ⇙ c" "g : b ↦⇘ℭ⇙ c" "f ∘⇩A⇘ℭ⇙ e = g ∘⇩A⇘ℭ⇙ e"
with semicategory_axioms e have "e ∘⇩A⇘op_smc ℭ⇙ f = e ∘⇩A⇘op_smc ℭ⇙ g"
by (cs_concl cs_simp: smc_op_simps cs_intro: smc_cs_intros)
then show "f = g"
by (rule is_monic_arrD[THEN conjunct2, rule_format, OF prems(1,2)])
qed
lemma (in semicategory) is_epic_arrE[elim!]:
assumes "e : a ↦⇩e⇩p⇩i⇘ℭ⇙ b"
obtains "e : a ↦⇘ℭ⇙ b"
and "⋀f g c. ⟦ f : b ↦⇘ℭ⇙ c; g : b ↦⇘ℭ⇙ c; f ∘⇩A⇘ℭ⇙ e = g ∘⇩A⇘ℭ⇙ e ⟧ ⟹
f = g"
using assms by auto
text‹Elementary properties.›
lemma (in semicategory) op_smc_is_epic_arr[smc_op_simps]:
"f : b ↦⇩e⇩p⇩i⇘op_smc ℭ⇙ a ⟷ f : a ↦⇩m⇩o⇩n⇘ℭ⇙ b"
unfolding is_monic_arr_def is_epic_arr_def smc_op_simps ..
lemma (in semicategory) op_smc_is_monic_arr[smc_op_simps]:
"f : b ↦⇩m⇩o⇩n⇘op_smc ℭ⇙ a ⟷ f : a ↦⇩e⇩p⇩i⇘ℭ⇙ b"
unfolding is_monic_arr_def is_epic_arr_def smc_op_simps ..
lemma (in semicategory) smc_Comp_is_monic_arr[smc_arrow_cs_intros]:
assumes "g : b ↦⇩m⇩o⇩n⇘ℭ⇙ c" and "f : a ↦⇩m⇩o⇩n⇘ℭ⇙ b"
shows "g ∘⇩A⇘ℭ⇙ f : a ↦⇩m⇩o⇩n⇘ℭ⇙ c"
proof(intro is_monic_arrI)
from assms show "g ∘⇩A⇘ℭ⇙ f : a ↦⇘ℭ⇙ c" by (auto intro: smc_cs_intros)
fix f' g' a'
assume f': "f' : a' ↦⇘ℭ⇙ a"
and g': "g' : a' ↦⇘ℭ⇙ a"
and "g ∘⇩A⇘ℭ⇙ f ∘⇩A⇘ℭ⇙ f' = g ∘⇩A⇘ℭ⇙ f ∘⇩A⇘ℭ⇙ g'"
with assms have "g ∘⇩A⇘ℭ⇙ (f ∘⇩A⇘ℭ⇙ f') = g ∘⇩A⇘ℭ⇙ (f ∘⇩A⇘ℭ⇙ g')"
by (force simp: smc_Comp_assoc)
moreover from assms have "f ∘⇩A⇘ℭ⇙ f' : a' ↦⇘ℭ⇙ b" "f ∘⇩A⇘ℭ⇙ g' : a' ↦⇘ℭ⇙ b"
by (auto intro: f' g' smc_cs_intros)
ultimately have "f ∘⇩A⇘ℭ⇙ f' = f ∘⇩A⇘ℭ⇙ g'" using assms(1) by clarsimp
with assms f' g' show "f' = g'" by clarsimp
qed
lemmas [smc_arrow_cs_intros] = semicategory.smc_Comp_is_monic_arr
lemma (in semicategory) smc_Comp_is_epic_arr[smc_arrow_cs_intros]:
assumes "g : b ↦⇩e⇩p⇩i⇘ℭ⇙ c" and "f : a ↦⇩e⇩p⇩i⇘ℭ⇙ b"
shows "g ∘⇩A⇘ℭ⇙ f : a ↦⇩e⇩p⇩i⇘ℭ⇙ c"
proof-
from assms op_smc_is_arr have "g : b ↦⇘ℭ⇙ c" "f : a ↦⇘ℭ⇙ b"
unfolding is_epic_arr_def by auto
with semicategory_axioms have "f ∘⇩A⇘op_smc ℭ⇙ g = g ∘⇩A⇘ℭ⇙ f"
by (cs_concl cs_simp: smc_op_simps)
with
semicategory.smc_Comp_is_monic_arr[
OF semicategory_op,
OF assms(2,1)[unfolded is_epic_arr_def],
folded is_epic_arr_def
]
show ?thesis
by auto
qed
lemmas [smc_arrow_cs_intros] = semicategory.smc_Comp_is_epic_arr
lemma (in semicategory) smc_Comp_is_monic_arr_is_monic_arr:
assumes "g : b ↦⇘ℭ⇙ c" and "f : a ↦⇘ℭ⇙ b" and "g ∘⇩A⇘ℭ⇙ f : a ↦⇩m⇩o⇩n⇘ℭ⇙ c"
shows "f : a ↦⇩m⇩o⇩n⇘ℭ⇙ b"
proof(intro is_monic_arrI)
fix f' g' a'
assume f': "f' : a' ↦⇘ℭ⇙ a"
and g': "g' : a' ↦⇘ℭ⇙ a"
and f'gg'g: "f ∘⇩A⇘ℭ⇙ f' = f ∘⇩A⇘ℭ⇙ g'"
from assms(1,2) f' g' have "(g ∘⇩A⇘ℭ⇙ f) ∘⇩A⇘ℭ⇙ f' = (g ∘⇩A⇘ℭ⇙ f) ∘⇩A⇘ℭ⇙ g'"
by (auto simp: smc_Comp_assoc f'gg'g)
with assms(3) f' g' show "f' = g'" by clarsimp
qed (simp add: assms(2))
lemma (in semicategory) smc_Comp_is_epic_arr_is_epic_arr:
assumes "g : a ↦⇘ℭ⇙ b" and "f : b ↦⇘ℭ⇙ c" and "f ∘⇩A⇘ℭ⇙ g : a ↦⇩e⇩p⇩i⇘ℭ⇙ c"
shows "f : b ↦⇩e⇩p⇩i⇘ℭ⇙ c"
proof-
from assms have "g : b ↦⇘op_smc ℭ⇙ a" "f : c ↦⇘op_smc ℭ⇙ b"
unfolding smc_op_simps by simp_all
moreover from semicategory_axioms assms have "g ∘⇩A⇘op_smc ℭ⇙ f : a ↦⇩e⇩p⇩i⇘ℭ⇙ c"
by (cs_concl cs_simp: smc_op_simps)
ultimately show ?thesis
using
semicategory.smc_Comp_is_monic_arr_is_monic_arr[
OF semicategory_op, folded is_epic_arr_def
]
by auto
qed
subsection‹Idempotent arrow›
text‹See Chapter I-5 in \cite{mac_lane_categories_2010}.›
definition is_idem_arr :: "V ⇒ V ⇒ V ⇒ bool"
where "is_idem_arr ℭ b f ⟷ f : b ↦⇘ℭ⇙ b ∧ f ∘⇩A⇘ℭ⇙ f = f"
syntax "_is_idem_arr" :: "V ⇒ V ⇒ V ⇒ bool" (‹_ : ↦⇩i⇩d⇩eı _› [51, 51] 51)
translations "f : ↦⇩i⇩d⇩e⇘ℭ⇙ b" ⇌ "CONST is_idem_arr ℭ b f"
text‹Rules.›
mk_ide rf is_idem_arr_def
|intro is_idem_arrI|
|dest is_idem_arrD[dest]|
|elim is_idem_arrE[elim!]|
lemmas [smc_cs_simps] = is_idem_arrD(2)
text‹Elementary properties.›
lemma (in semicategory) op_smc_is_idem_arr[smc_op_simps]:
"f : ↦⇩i⇩d⇩e⇘op_smc ℭ⇙ b ⟷ f : ↦⇩i⇩d⇩e⇘ℭ⇙ b"
using op_smc_Comp unfolding is_idem_arr_def smc_op_simps by auto
subsection‹Terminal object and initial object›
text‹See Chapter I-5 in \cite{mac_lane_categories_2010}.›
definition obj_terminal :: "V ⇒ V ⇒ bool"
where "obj_terminal ℭ t ⟷
t ∈⇩∘ ℭ⦇Obj⦈ ∧ (∀a. a ∈⇩∘ ℭ⦇Obj⦈ ⟶ (∃!f. f : a ↦⇘ℭ⇙ t))"
definition obj_initial :: "V ⇒ V ⇒ bool"
where "obj_initial ℭ ≡ obj_terminal (op_smc ℭ)"
text‹Rules.›
mk_ide rf obj_terminal_def
|intro obj_terminalI|
|dest obj_terminalD[dest]|
|elim obj_terminalE[elim]|
lemma obj_initialI:
assumes "a ∈⇩∘ ℭ⦇Obj⦈" and "⋀b. b ∈⇩∘ ℭ⦇Obj⦈ ⟹ ∃!f. f : a ↦⇘ℭ⇙ b"
shows "obj_initial ℭ a"
unfolding obj_initial_def
by (simp add: obj_terminalI[of _ ‹op_smc ℭ›, unfolded smc_op_simps, OF assms])
lemma obj_initialD[dest]:
assumes "obj_initial ℭ a"
shows "a ∈⇩∘ ℭ⦇Obj⦈" and "⋀b. b ∈⇩∘ ℭ⦇Obj⦈ ⟹ ∃!f. f : a ↦⇘ℭ⇙ b"
by
(
simp_all add:
obj_terminalD[OF assms[unfolded obj_initial_def], unfolded smc_op_simps]
)
lemma obj_initialE[elim]:
assumes "obj_initial ℭ a"
obtains "a ∈⇩∘ ℭ⦇Obj⦈" and "⋀b. b ∈⇩∘ ℭ⦇Obj⦈ ⟹ ∃!f. f : a ↦⇘ℭ⇙ b"
using assms by (auto simp: obj_initialD)
text‹Elementary properties.›
lemma op_smc_obj_initial[smc_op_simps]:
"obj_initial (op_smc ℭ) = obj_terminal ℭ"
unfolding obj_initial_def obj_terminal_def smc_op_simps ..
lemma op_smc_obj_terminal[smc_op_simps]:
"obj_terminal (op_smc ℭ) = obj_initial ℭ"
unfolding obj_initial_def obj_terminal_def smc_op_simps ..
subsection‹Null object›
text‹See Chapter I-5 in \cite{mac_lane_categories_2010}.›
definition obj_null :: "V ⇒ V ⇒ bool"
where "obj_null ℭ a ⟷ obj_initial ℭ a ∧ obj_terminal ℭ a"
text‹Rules.›
mk_ide rf obj_null_def
|intro obj_nullI|
|dest obj_nullD[dest]|
|elim obj_nullE[elim]|
text‹Elementary properties.›
lemma op_smc_obj_null[smc_op_simps]: "obj_null (op_smc ℭ) a = obj_null ℭ a"
unfolding obj_null_def smc_op_simps by auto
subsection‹Zero arrow›
definition is_zero_arr :: "V ⇒ V ⇒ V ⇒ V ⇒ bool"
where "is_zero_arr ℭ a b h ⟷
(∃z g f. obj_null ℭ z ∧ h = g ∘⇩A⇘ℭ⇙ f ∧ f : a ↦⇘ℭ⇙ z ∧ g : z ↦⇘ℭ⇙ b)"
syntax "_is_zero_arr" :: "V ⇒ V ⇒ V ⇒ V ⇒ bool"
(‹_ : _ ↦⇩0ı _› [51, 51, 51] 51)
translations "h : a ↦⇩0⇘ℭ⇙ b" ⇌ "CONST is_zero_arr ℭ a b h"
text‹Rules.›
lemma is_zero_arrI:
assumes "obj_null ℭ z"
and "h = g ∘⇩A⇘ℭ⇙ f"
and "f : a ↦⇘ℭ⇙ z"
and "g : z ↦⇘ℭ⇙ b"
shows "h : a ↦⇩0⇘ℭ⇙ b"
using assms unfolding is_zero_arr_def by auto
lemma is_zero_arrD[dest]:
assumes "h : a ↦⇩0⇘ℭ⇙ b"
shows "∃z g f. obj_null ℭ z ∧ h = g ∘⇩A⇘ℭ⇙ f ∧ f : a ↦⇘ℭ⇙ z ∧ g : z ↦⇘ℭ⇙ b"
using assms unfolding is_zero_arr_def by simp
lemma is_zero_arrE[elim]:
assumes "h : a ↦⇩0⇘ℭ⇙ b"
obtains z g f
where "obj_null ℭ z"
and "h = g ∘⇩A⇘ℭ⇙ f"
and "f : a ↦⇘ℭ⇙ z"
and "g : z ↦⇘ℭ⇙ b"
using assms by auto
text‹Elementary properties.›
lemma (in semicategory) op_smc_is_zero_arr[smc_op_simps]:
"f : b ↦⇩0⇘op_smc ℭ⇙ a ⟷ f : a ↦⇩0⇘ℭ⇙ b"
using op_smc_Comp unfolding is_zero_arr_def smc_op_simps by metis
lemma (in semicategory) smc_is_zero_arr_Comp_right:
assumes "h : b ↦⇩0⇘ℭ⇙ c" and "h' : a ↦⇘ℭ⇙ b"
shows "h ∘⇩A⇘ℭ⇙ h' : a ↦⇩0⇘ℭ⇙ c"
proof-
from assms(1) obtain z g f
where "obj_null ℭ z"
and "h = g ∘⇩A⇘ℭ⇙ f"
and "f : b ↦⇘ℭ⇙ z"
and "g : z ↦⇘ℭ⇙ c"
by auto
with assms show ?thesis
by (auto simp: smc_cs_simps intro: is_zero_arrI smc_cs_intros)
qed
lemmas [smc_arrow_cs_intros] = semicategory.smc_is_zero_arr_Comp_right
lemma (in semicategory) smc_is_zero_arr_Comp_left:
assumes "h' : b ↦⇘ℭ⇙ c" and "h : a ↦⇩0⇘ℭ⇙ b"
shows "h' ∘⇩A⇘ℭ⇙ h : a ↦⇩0⇘ℭ⇙ c"
proof-
from assms(2) obtain z g f
where "obj_null ℭ z"
and "h = g ∘⇩A⇘ℭ⇙ f"
and "f : a ↦⇘ℭ⇙ z"
and "g : z ↦⇘ℭ⇙ b"
by auto
with assms(1) show ?thesis
by (intro is_zero_arrI[of _ _ _ ‹h' ∘⇩A⇘ℭ⇙ g›])
(auto simp: smc_Comp_assoc intro: is_zero_arrI smc_cs_intros)
qed
lemmas [smc_arrow_cs_intros] = semicategory.smc_is_zero_arr_Comp_left
text‹\newpage›
end
Theory CZH_SMC_Small_Semicategory
section‹Smallness for semicategories›
theory CZH_SMC_Small_Semicategory
imports
CZH_DG_Small_Digraph
CZH_SMC_Semicategory
begin
subsection‹Background›
text‹
An explanation of the methodology chosen for the exposition of all
matters related to the size of the semicategories and associated entities
is given in the previous chapter.
›
named_theorems smc_small_cs_simps
named_theorems smc_small_cs_intros
subsection‹Tiny semicategory›
subsubsection‹Definition and elementary properties›
locale tiny_semicategory = 𝒵 α + vfsequence ℭ + Comp: vsv ‹ℭ⦇Comp⦈› for α ℭ +
assumes tiny_smc_length[smc_cs_simps]: "vcard ℭ = 5⇩ℕ"
and tiny_smc_tiny_digraph[slicing_intros]: "tiny_digraph α (smc_dg ℭ)"
and tiny_smc_Comp_vdomain: "gf ∈⇩∘ 𝒟⇩∘ (ℭ⦇Comp⦈) ⟷
(∃g f b c a. gf = [g, f]⇩∘ ∧ g : b ↦⇘ℭ⇙ c ∧ f : a ↦⇘ℭ⇙ b)"
and tiny_smc_Comp_is_arr[smc_cs_intros]:
"⟦ g : b ↦⇘ℭ⇙ c; f : a ↦⇘ℭ⇙ b ⟧ ⟹ g ∘⇩A⇘ℭ⇙ f : a ↦⇘ℭ⇙ c"
and tiny_smc_assoc[smc_cs_simps]:
"⟦ h : c ↦⇘ℭ⇙ d; g : b ↦⇘ℭ⇙ c; f : a ↦⇘ℭ⇙ b ⟧ ⟹
(h ∘⇩A⇘ℭ⇙ g) ∘⇩A⇘ℭ⇙ f = h ∘⇩A⇘ℭ⇙ (g ∘⇩A⇘ℭ⇙ f)"
lemmas [smc_cs_simps] =
tiny_semicategory.tiny_smc_length
tiny_semicategory.tiny_smc_assoc
lemmas [slicing_intros] =
tiny_semicategory.tiny_smc_Comp_is_arr
text‹Rules.›
lemma (in tiny_semicategory) tiny_semicategory_axioms'[smc_small_cs_intros]:
assumes "α' = α"
shows "tiny_semicategory α' ℭ"
unfolding assms by (rule tiny_semicategory_axioms)
mk_ide rf tiny_semicategory_def[unfolded tiny_semicategory_axioms_def]
|intro tiny_semicategoryI|
|dest tiny_semicategoryD[dest]|
|elim tiny_semicategoryE[elim]|
lemma tiny_semicategoryI':
assumes "semicategory α ℭ" and "ℭ⦇Obj⦈ ∈⇩∘ Vset α" and "ℭ⦇Arr⦈ ∈⇩∘ Vset α"
shows "tiny_semicategory α ℭ"
proof-
interpret semicategory α ℭ by (rule assms(1))
show ?thesis
proof(intro tiny_semicategoryI)
show "vfsequence ℭ" by (simp add: vfsequence_axioms)
from assms show "tiny_digraph α (smc_dg ℭ)"
by (intro tiny_digraphI') (auto simp: slicing_simps)
qed (auto simp: smc_cs_simps intro: smc_cs_intros)
qed
lemma tiny_semicategoryI'':
assumes "𝒵 α"
and "vfsequence ℭ"
and "vsv (ℭ⦇Comp⦈)"
and "vcard ℭ = 5⇩ℕ"
and "vsv (ℭ⦇Dom⦈)"
and "vsv (ℭ⦇Cod⦈)"
and "𝒟⇩∘ (ℭ⦇Dom⦈) = ℭ⦇Arr⦈"
and "ℛ⇩∘ (ℭ⦇Dom⦈) ⊆⇩∘ ℭ⦇Obj⦈"
and "𝒟⇩∘ (ℭ⦇Cod⦈) = ℭ⦇Arr⦈"
and "ℛ⇩∘ (ℭ⦇Cod⦈) ⊆⇩∘ ℭ⦇Obj⦈"
and "⋀gf. gf ∈⇩∘ 𝒟⇩∘ (ℭ⦇Comp⦈) ⟷
(∃g f b c a. gf = [g, f]⇩∘ ∧ g : b ↦⇘ℭ⇙ c ∧ f : a ↦⇘ℭ⇙ b)"
and "⋀b c g a f. ⟦ g : b ↦⇘ℭ⇙ c; f : a ↦⇘ℭ⇙ b ⟧ ⟹ g ∘⇩A⇘ℭ⇙ f : a ↦⇘ℭ⇙ c"
and "⋀c d h b g a f. ⟦ h : c ↦⇘ℭ⇙ d; g : b ↦⇘ℭ⇙ c; f : a ↦⇘ℭ⇙ b ⟧ ⟹
(h ∘⇩A⇘ℭ⇙ g) ∘⇩A⇘ℭ⇙ f = h ∘⇩A⇘ℭ⇙ (g ∘⇩A⇘ℭ⇙ f)"
and "ℭ⦇Obj⦈ ∈⇩∘ Vset α"
and "ℭ⦇Arr⦈ ∈⇩∘ Vset α"
shows "tiny_semicategory α ℭ"
by (intro tiny_semicategoryI tiny_digraphI, unfold slicing_simps)
(simp_all add: smc_dg_def nat_omega_simps assms)
text‹Slicing.›
context tiny_semicategory
begin
interpretation dg: tiny_digraph α ‹smc_dg ℭ› by (rule tiny_smc_tiny_digraph)
lemmas_with [unfolded slicing_simps]:
tiny_smc_Obj_in_Vset[smc_small_cs_intros] = dg.tiny_dg_Obj_in_Vset
and tiny_smc_Arr_in_Vset[smc_small_cs_intros] = dg.tiny_dg_Arr_in_Vset
and tiny_smc_Dom_in_Vset[smc_small_cs_intros] = dg.tiny_dg_Dom_in_Vset
and tiny_smc_Cod_in_Vset[smc_small_cs_intros] = dg.tiny_dg_Cod_in_Vset
end
text‹Elementary properties.›
sublocale tiny_semicategory ⊆ semicategory
by (rule semicategoryI)
(
auto
simp:
vfsequence_axioms
tiny_digraph.tiny_dg_digraph
tiny_smc_tiny_digraph
tiny_smc_Comp_vdomain
intro: smc_cs_intros smc_cs_simps
)
lemmas (in tiny_semicategory) tiny_dg_semicategory = semicategory_axioms
lemmas [smc_small_cs_intros] = tiny_semicategory.tiny_dg_semicategory
text‹Size.›
lemma (in tiny_semicategory) tiny_smc_Comp_in_Vset: "ℭ⦇Comp⦈ ∈⇩∘ Vset α"
proof-
have "ℭ⦇Arr⦈ ∈⇩∘ Vset α" by (simp add: tiny_smc_Arr_in_Vset)
with Axiom_of_Infinity have "ℭ⦇Arr⦈ ^⇩× 2⇩ℕ ∈⇩∘ Vset α"
by (intro Limit_vcpower_in_VsetI) auto
with Comp.pnop_vdomain have D: "𝒟⇩∘ (ℭ⦇Comp⦈) ∈⇩∘ Vset α" by auto
moreover from tiny_smc_Arr_in_Vset smc_Comp_vrange have
"ℛ⇩∘ (ℭ⦇Comp⦈) ∈⇩∘ Vset α"
by auto
ultimately show ?thesis by (simp add: Comp.vbrelation_Limit_in_VsetI)
qed
lemma (in tiny_semicategory) tiny_smc_in_Vset: "ℭ ∈⇩∘ Vset α"
proof-
note [smc_cs_intros] =
tiny_smc_Obj_in_Vset
tiny_smc_Arr_in_Vset
tiny_smc_Dom_in_Vset
tiny_smc_Cod_in_Vset
tiny_smc_Comp_in_Vset
show ?thesis by (subst smc_def) (cs_concl cs_intro: smc_cs_intros V_cs_intros)
qed
lemma small_tiny_semicategories[simp]: "small {ℭ. tiny_semicategory α ℭ}"
proof(rule down)
show "{ℭ. tiny_semicategory α ℭ} ⊆ elts (set {ℭ. semicategory α ℭ})"
by (auto intro: smc_small_cs_intros)
qed
lemma tiny_semicategories_vsubset_Vset:
"set {ℭ. tiny_semicategory α ℭ} ⊆⇩∘ Vset α"
by (rule vsubsetI) (simp add: tiny_semicategory.tiny_smc_in_Vset)
lemma (in semicategory) smc_tiny_semicategory_if_ge_Limit:
assumes "𝒵 β" and "α ∈⇩∘ β"
shows "tiny_semicategory β ℭ"
proof(intro tiny_semicategoryI)
show "tiny_digraph β (smc_dg ℭ)"
by (rule digraph.dg_tiny_digraph_if_ge_Limit, rule smc_digraph; intro assms)
qed
(
auto simp:
assms(1)
smc_cs_simps
smc_cs_intros
smc_digraph digraph.dg_tiny_digraph_if_ge_Limit
smc_Comp_vdomain vfsequence_axioms
)
subsubsection‹Opposite tiny semicategory›
lemma (in tiny_semicategory) tiny_semicategory_op:
"tiny_semicategory α (op_smc ℭ)"
by (intro tiny_semicategoryI', unfold smc_op_simps)
(auto simp: smc_op_intros smc_small_cs_intros)
lemmas tiny_semicategory_op[smc_op_intros] =
tiny_semicategory.tiny_semicategory_op
subsection‹Finite semicategory›
subsubsection‹Definition and elementary properties›
text‹
A finite semicategory is a generalization of the concept of a finite category,
as presented in nLab
\cite{noauthor_nlab_nodate}
\footnote{\url{https://ncatlab.org/nlab/show/finite+category}}.
›
locale finite_semicategory = 𝒵 α + vfsequence ℭ + Comp: vsv ‹ℭ⦇Comp⦈› for α ℭ +
assumes fin_smc_length[smc_cs_simps]: "vcard ℭ = 5⇩ℕ"
and fin_smc_finite_digraph[slicing_intros]: "finite_digraph α (smc_dg ℭ)"
and fin_smc_Comp_vdomain: "gf ∈⇩∘ 𝒟⇩∘ (ℭ⦇Comp⦈) ⟷
(∃g f b c a. gf = [g, f]⇩∘ ∧ g : b ↦⇘ℭ⇙ c ∧ f : a ↦⇘ℭ⇙ b)"
and fin_smc_Comp_is_arr[smc_cs_intros]:
"⟦ g : b ↦⇘ℭ⇙ c; f : a ↦⇘ℭ⇙ b ⟧ ⟹ g ∘⇩A⇘ℭ⇙ f : a ↦⇘ℭ⇙ c"
and fin_smc_assoc[smc_cs_simps]:
"⟦ h : c ↦⇘ℭ⇙ d; g : b ↦⇘ℭ⇙ c; f : a ↦⇘ℭ⇙ b ⟧ ⟹
(h ∘⇩A⇘ℭ⇙ g) ∘⇩A⇘ℭ⇙ f = h ∘⇩A⇘ℭ⇙ (g ∘⇩A⇘ℭ⇙ f)"
lemmas [smc_cs_simps] =
finite_semicategory.fin_smc_length
finite_semicategory.fin_smc_assoc
lemmas [slicing_intros] =
finite_semicategory.fin_smc_Comp_is_arr
text‹Rules.›
lemma (in finite_semicategory) finite_semicategory_axioms'[smc_small_cs_intros]:
assumes "α' = α"
shows "finite_semicategory α' ℭ"
unfolding assms by (rule finite_semicategory_axioms)
mk_ide rf finite_semicategory_def[unfolded finite_semicategory_axioms_def]
|intro finite_semicategoryI|
|dest finite_semicategoryD[dest]|
|elim finite_semicategoryE[elim]|
lemma finite_semicategoryI':
assumes "semicategory α ℭ" and "vfinite (ℭ⦇Obj⦈)" and "vfinite (ℭ⦇Arr⦈)"
shows "finite_semicategory α ℭ"
proof-
interpret semicategory α ℭ by (rule assms(1))
show ?thesis
proof(intro finite_semicategoryI)
show "vfsequence ℭ" by (simp add: vfsequence_axioms)
from assms show "finite_digraph α (smc_dg ℭ)"
by (intro finite_digraphI) (auto simp: slicing_simps)
qed (auto simp: smc_cs_simps intro: smc_cs_intros)
qed
lemma finite_semicategoryI'':
assumes "tiny_semicategory α ℭ" and "vfinite (ℭ⦇Obj⦈)" and "vfinite (ℭ⦇Arr⦈)"
shows "finite_semicategory α ℭ"
using assms by (intro finite_semicategoryI')
(auto intro: smc_cs_intros smc_small_cs_intros)
text‹Slicing.›
context finite_semicategory
begin
interpretation dg: finite_digraph α ‹smc_dg ℭ› by (rule fin_smc_finite_digraph)
lemmas_with [unfolded slicing_simps]:
fin_smc_Obj_vfinite[smc_small_cs_intros] = dg.fin_dg_Obj_vfinite
and fin_smc_Arr_vfinite[smc_small_cs_intros] = dg.fin_dg_Arr_vfinite
end
text‹Elementary properties.›
sublocale finite_semicategory ⊆ tiny_semicategory
by (rule tiny_semicategoryI)
(
auto simp:
vfsequence_axioms
fin_smc_Comp_vdomain
fin_smc_finite_digraph
finite_digraph.fin_dg_tiny_digraph
intro: smc_cs_intros smc_cs_simps
)
lemmas (in finite_semicategory) fin_smc_tiny_semicategory =
tiny_semicategory_axioms
lemmas [smc_small_cs_intros] = finite_semicategory.fin_smc_tiny_semicategory
lemma (in finite_semicategory) fin_smc_in_Vset: "ℭ ∈⇩∘ Vset α"
by (rule tiny_smc_in_Vset)
text‹Size.›
lemma small_finite_semicategories[simp]: "small {ℭ. finite_semicategory α ℭ}"
proof(rule down)
show "{ℭ. finite_semicategory α ℭ} ⊆ elts (set {ℭ. semicategory α ℭ})"
by (auto intro: smc_small_cs_intros)
qed
lemma finite_semicategories_vsubset_Vset:
"set {ℭ. finite_semicategory α ℭ} ⊆⇩∘ Vset α"
by (rule vsubsetI) (simp add: finite_semicategory.fin_smc_in_Vset)
subsubsection‹Opposite finite semicategory›
lemma (in finite_semicategory) finite_semicategory_op:
"finite_semicategory α (op_smc ℭ)"
by (intro finite_semicategoryI', unfold smc_op_simps)
(auto simp: smc_op_intros smc_small_cs_intros)
lemmas finite_semicategory_op[smc_op_intros] =
finite_semicategory.finite_semicategory_op
text‹\newpage›
end
Theory CZH_SMC_Semifunctor
section‹Semifunctor›
theory CZH_SMC_Semifunctor
imports
CZH_DG_DGHM
CZH_SMC_Semicategory
begin
subsection‹Background›
named_theorems smcf_cs_simps
named_theorems smcf_cs_intros
named_theorems smc_cn_cs_simps
named_theorems smc_cn_cs_intros
lemmas [smc_cs_simps] = dg_shared_cs_simps
lemmas [smc_cs_intros] = dg_shared_cs_intros
subsubsection‹Slicing›
definition smcf_dghm :: "V ⇒ V"
where "smcf_dghm ℭ =
[ℭ⦇ObjMap⦈, ℭ⦇ArrMap⦈, smc_dg (ℭ⦇HomDom⦈), smc_dg (ℭ⦇HomCod⦈)]⇩∘"
text‹Components.›
lemma smcf_dghm_components:
shows [slicing_simps]: "smcf_dghm 𝔉⦇ObjMap⦈ = 𝔉⦇ObjMap⦈"
and [slicing_simps]: "smcf_dghm 𝔉⦇ArrMap⦈ = 𝔉⦇ArrMap⦈"
and [slicing_commute]: "smcf_dghm 𝔉⦇HomDom⦈ = smc_dg (𝔉⦇HomDom⦈)"
and [slicing_commute]: "smcf_dghm 𝔉⦇HomCod⦈ = smc_dg (𝔉⦇HomCod⦈)"
unfolding smcf_dghm_def dghm_field_simps by (auto simp: nat_omega_simps)
subsection‹Definition and elementary properties›
text‹
See Chapter I-3 in \cite{mac_lane_categories_2010} and the description
of the concept of a digraph homomorphism in the previous chapter.
›
locale is_semifunctor =
𝒵 α +
vfsequence 𝔉 +
HomDom: semicategory α 𝔄 +
HomCod: semicategory α 𝔅
for α 𝔄 𝔅 𝔉 +
assumes smcf_length[smc_cs_simps]: "vcard 𝔉 = 4⇩ℕ"
and smcf_is_dghm[slicing_intros]:
"smcf_dghm 𝔉 : smc_dg 𝔄 ↦↦⇩D⇩G⇘α⇙ smc_dg 𝔅"
and smcf_HomDom[smc_cs_simps]: "𝔉⦇HomDom⦈ = 𝔄"
and smcf_HomCod[smc_cs_simps]: "𝔉⦇HomCod⦈ = 𝔅"
and smcf_ArrMap_Comp[smc_cs_simps]: "⟦ g : b ↦⇘𝔄⇙ c; f : a ↦⇘𝔄⇙ b ⟧ ⟹
𝔉⦇ArrMap⦈⦇g ∘⇩A⇘𝔄⇙ f⦈ = 𝔉⦇ArrMap⦈⦇g⦈ ∘⇩A⇘𝔅⇙ 𝔉⦇ArrMap⦈⦇f⦈"
syntax "_is_semifunctor" :: "V ⇒ V ⇒ V ⇒ V ⇒ bool"
(‹(_ :/ _ ↦↦⇩S⇩M⇩Cı _)› [51, 51, 51] 51)
translations "𝔉 : 𝔄 ↦↦⇩S⇩M⇩C⇘α⇙ 𝔅" ⇌ "CONST is_semifunctor α 𝔄 𝔅 𝔉"
abbreviation (input) is_cn_semifunctor :: "V ⇒ V ⇒ V ⇒ V ⇒ bool"
where "is_cn_semifunctor α 𝔄 𝔅 𝔉 ≡ 𝔉 : op_smc 𝔄 ↦↦⇩S⇩M⇩C⇘α⇙ 𝔅"
syntax "_is_cn_semifunctor" :: "V ⇒ V ⇒ V ⇒ V ⇒ bool"
(‹(_ :/ _ ⇩S⇩M⇩C↦↦ı _)› [51, 51, 51] 51)
translations "𝔉 : 𝔄 ⇩S⇩M⇩C↦↦⇘α⇙ 𝔅" ⇀ "CONST is_cn_semifunctor α 𝔄 𝔅 𝔉"
abbreviation all_smcfs :: "V ⇒ V"
where "all_smcfs α ≡ set {𝔉. ∃𝔄 𝔅. 𝔉 : 𝔄 ↦↦⇩S⇩M⇩C⇘α⇙ 𝔅}"
abbreviation smcfs :: "V ⇒ V ⇒ V ⇒ V"
where "smcfs α 𝔄 𝔅 ≡ set {𝔉. 𝔉 : 𝔄 ↦↦⇩S⇩M⇩C⇘α⇙ 𝔅}"
lemmas [smc_cs_simps] =
is_semifunctor.smcf_HomDom
is_semifunctor.smcf_HomCod
is_semifunctor.smcf_ArrMap_Comp
lemma smcf_is_dghm'[slicing_intros]:
assumes "𝔉 : 𝔄 ↦↦⇩S⇩M⇩C⇘α⇙ 𝔅"
and "𝔄' = smc_dg 𝔄"
and "𝔅' = smc_dg 𝔅"
shows "smcf_dghm 𝔉 : 𝔄' ↦↦⇩D⇩G⇘α⇙ 𝔅'"
using assms(1) unfolding assms(2,3) by (rule is_semifunctor.smcf_is_dghm)
lemma cn_dghm_comp_is_dghm:
assumes "𝔉 : op_smc 𝔄 ↦↦⇩S⇩M⇩C⇘α⇙ 𝔅"
shows "smcf_dghm 𝔉 : op_dg (smc_dg 𝔄) ↦↦⇩D⇩G⇘α⇙ smc_dg 𝔅"
using assms
unfolding slicing_simps slicing_commute
by (cs_concl cs_intro: slicing_intros)
lemma cn_dghm_comp_is_dghm'[slicing_intros]:
assumes "𝔉 : op_smc 𝔄 ↦↦⇩S⇩M⇩C⇘α⇙ 𝔅"
and "𝔄' = op_dg (smc_dg 𝔄)"
and "𝔅' = smc_dg 𝔅"
shows "smcf_dghm 𝔉 : 𝔄' ↦↦⇩D⇩G⇘α⇙ 𝔅'"
using assms(1) unfolding assms(2,3) by (rule cn_dghm_comp_is_dghm)
text‹Rules.›
lemma (in is_semifunctor) is_semifunctor_axioms'[smc_cs_intros]:
assumes "α' = α" and "𝔄' = 𝔄" and "𝔅' = 𝔅"
shows "𝔉 : 𝔄' ↦↦⇩S⇩M⇩C⇘α'⇙ 𝔅'"
unfolding assms by (rule is_semifunctor_axioms)
mk_ide rf is_semifunctor_def[unfolded is_semifunctor_axioms_def]
|intro is_semifunctorI|
|dest is_semifunctorD[dest]|
|elim is_semifunctorE[elim]|
lemmas [smc_cs_intros] =
is_semifunctorD(3,4)
lemma is_semifunctorI':
assumes "𝒵 α"
and "vfsequence 𝔉"
and "semicategory α 𝔄"
and "semicategory α 𝔅"
and "vcard 𝔉 = 4⇩ℕ"
and "𝔉⦇HomDom⦈ = 𝔄"
and "𝔉⦇HomCod⦈ = 𝔅"
and "vsv (𝔉⦇ObjMap⦈)"
and "vsv (𝔉⦇ArrMap⦈)"
and "𝒟⇩∘ (𝔉⦇ObjMap⦈) = 𝔄⦇Obj⦈"
and "ℛ⇩∘ (𝔉⦇ObjMap⦈) ⊆⇩∘ 𝔅⦇Obj⦈"
and "𝒟⇩∘ (𝔉⦇ArrMap⦈) = 𝔄⦇Arr⦈"
and "⋀a b f. f : a ↦⇘𝔄⇙ b ⟹
𝔉⦇ArrMap⦈⦇f⦈ : 𝔉⦇ObjMap⦈⦇a⦈ ↦⇘𝔅⇙ 𝔉⦇ObjMap⦈⦇b⦈"
and "⋀b c g a f. ⟦ g : b ↦⇘𝔄⇙ c; f : a ↦⇘𝔄⇙ b ⟧ ⟹
𝔉⦇ArrMap⦈⦇g ∘⇩A⇘𝔄⇙ f⦈ = 𝔉⦇ArrMap⦈⦇g⦈ ∘⇩A⇘𝔅⇙ 𝔉⦇ArrMap⦈⦇f⦈"
shows "𝔉 : 𝔄 ↦↦⇩S⇩M⇩C⇘α⇙ 𝔅"
by (intro is_semifunctorI is_dghmI, unfold smcf_dghm_components slicing_simps)
(simp_all add: assms smcf_dghm_def nat_omega_simps semicategory.smc_digraph)
lemma is_semifunctorD':
assumes "𝔉 : 𝔄 ↦↦⇩S⇩M⇩C⇘α⇙ 𝔅"
shows "𝒵 α"
and "vfsequence 𝔉"
and "semicategory α 𝔄"
and "semicategory α 𝔅"
and "vcard 𝔉 = 4⇩ℕ"
and "𝔉⦇HomDom⦈ = 𝔄"
and "𝔉⦇HomCod⦈ = 𝔅"
and "vsv (𝔉⦇ObjMap⦈)"
and "vsv (𝔉⦇ArrMap⦈)"
and "𝒟⇩∘ (𝔉⦇ObjMap⦈) = 𝔄⦇Obj⦈"
and "ℛ⇩∘ (𝔉⦇ObjMap⦈) ⊆⇩∘ 𝔅⦇Obj⦈"
and "𝒟⇩∘ (𝔉⦇ArrMap⦈) = 𝔄⦇Arr⦈"
and "⋀a b f. f : a ↦⇘𝔄⇙ b ⟹
𝔉⦇ArrMap⦈⦇f⦈ : 𝔉⦇ObjMap⦈⦇a⦈ ↦⇘𝔅⇙ 𝔉⦇ObjMap⦈⦇b⦈"
and "⋀b c g a f. ⟦ g : b ↦⇘𝔄⇙ c; f : a ↦⇘𝔄⇙ b ⟧ ⟹
𝔉⦇ArrMap⦈⦇g ∘⇩A⇘𝔄⇙ f⦈ = 𝔉⦇ArrMap⦈⦇g⦈ ∘⇩A⇘𝔅⇙ 𝔉⦇ArrMap⦈⦇f⦈"
by
(
simp_all add:
is_semifunctorD(2-9)[OF assms]
is_dghmD[OF is_semifunctorD(6)[OF assms], unfolded slicing_simps]
)
lemma is_semifunctorE':
assumes "𝔉 : 𝔄 ↦↦⇩S⇩M⇩C⇘α⇙ 𝔅"
obtains "𝒵 α"
and "vfsequence 𝔉"
and "semicategory α 𝔄"
and "semicategory α 𝔅"
and "vcard 𝔉 = 4⇩ℕ"
and "𝔉⦇HomDom⦈ = 𝔄"
and "𝔉⦇HomCod⦈ = 𝔅"
and "vsv (𝔉⦇ObjMap⦈)"
and "vsv (𝔉⦇ArrMap⦈)"
and "𝒟⇩∘ (𝔉⦇ObjMap⦈) = 𝔄⦇Obj⦈"
and "ℛ⇩∘ (𝔉⦇ObjMap⦈) ⊆⇩∘ 𝔅⦇Obj⦈"
and "𝒟⇩∘ (𝔉⦇ArrMap⦈) = 𝔄⦇Arr⦈"
and "⋀a b f. f : a ↦⇘𝔄⇙ b ⟹
𝔉⦇ArrMap⦈⦇f⦈ : 𝔉⦇ObjMap⦈⦇a⦈ ↦⇘𝔅⇙ 𝔉⦇ObjMap⦈⦇b⦈"
and "⋀b c g a f. ⟦ g : b ↦⇘𝔄⇙ c; f : a ↦⇘𝔄⇙ b ⟧ ⟹
𝔉⦇ArrMap⦈⦇g ∘⇩A⇘𝔄⇙ f⦈ = 𝔉⦇ArrMap⦈⦇g⦈ ∘⇩A⇘𝔅⇙ 𝔉⦇ArrMap⦈⦇f⦈"
using assms by (simp add: is_semifunctorD')
text‹Slicing.›
context is_semifunctor
begin
interpretation dghm: is_dghm α ‹smc_dg 𝔄› ‹smc_dg 𝔅› ‹smcf_dghm 𝔉›
by (rule smcf_is_dghm)
sublocale ObjMap: vsv ‹𝔉⦇ObjMap⦈›
by (rule dghm.ObjMap.vsv_axioms[unfolded slicing_simps])
sublocale ArrMap: vsv ‹𝔉⦇ArrMap⦈›
by (rule dghm.ArrMap.vsv_axioms[unfolded slicing_simps])
lemmas_with [unfolded slicing_simps]:
smcf_ObjMap_vsv = dghm.dghm_ObjMap_vsv
and smcf_ArrMap_vsv = dghm.dghm_ArrMap_vsv
and smcf_ObjMap_vdomain[smc_cs_simps] = dghm.dghm_ObjMap_vdomain
and smcf_ObjMap_vrange = dghm.dghm_ObjMap_vrange
and smcf_ArrMap_vdomain[smc_cs_simps] = dghm.dghm_ArrMap_vdomain
and smcf_ArrMap_is_arr = dghm.dghm_ArrMap_is_arr
and smcf_ArrMap_is_arr''[smc_cs_intros] = dghm.dghm_ArrMap_is_arr''
and smcf_ArrMap_is_arr'[smc_cs_intros] = dghm.dghm_ArrMap_is_arr'
and smcf_ObjMap_app_in_HomCod_Obj[smc_cs_intros] =
dghm.dghm_ObjMap_app_in_HomCod_Obj
and smcf_ArrMap_vrange = dghm.dghm_ArrMap_vrange
and smcf_ArrMap_app_in_HomCod_Arr[smc_cs_intros] =
dghm.dghm_ArrMap_app_in_HomCod_Arr
and smcf_ObjMap_vsubset_Vset = dghm.dghm_ObjMap_vsubset_Vset
and smcf_ArrMap_vsubset_Vset = dghm.dghm_ArrMap_vsubset_Vset
and smcf_ObjMap_in_Vset = dghm.dghm_ObjMap_in_Vset
and smcf_ArrMap_in_Vset = dghm.dghm_ArrMap_in_Vset
and smcf_is_dghm_if_ge_Limit = dghm.dghm_is_dghm_if_ge_Limit
and smcf_is_arr_HomCod = dghm.dghm_is_arr_HomCod
and smcf_vimage_dghm_ArrMap_vsubset_Hom =
dghm.dghm_vimage_dghm_ArrMap_vsubset_Hom
end
lemmas [smc_cs_simps] =
is_semifunctor.smcf_ObjMap_vdomain
is_semifunctor.smcf_ArrMap_vdomain
lemmas [smc_cs_intros] =
is_semifunctor.smcf_ObjMap_app_in_HomCod_Obj
is_semifunctor.smcf_ArrMap_app_in_HomCod_Arr
is_semifunctor.smcf_ArrMap_is_arr'
text‹Elementary properties.›
lemma cn_smcf_ArrMap_Comp[smc_cs_simps]:
assumes "semicategory α 𝔄"
and "𝔉 : op_smc 𝔄 ↦↦⇩S⇩M⇩C⇘α⇙ 𝔅"
and "g : c ↦⇘𝔄⇙ b"
and "f : b ↦⇘𝔄⇙ a"
shows "𝔉⦇ArrMap⦈⦇f ∘⇩A⇘𝔄⇙ g⦈ = 𝔉⦇ArrMap⦈⦇g⦈ ∘⇩A⇘𝔅⇙ 𝔉⦇ArrMap⦈⦇f⦈"
proof-
from assms(3,4) have gf:
"𝔉⦇ArrMap⦈⦇g⦈ ∘⇩A⇘𝔅⇙ 𝔉⦇ArrMap⦈⦇f⦈ = 𝔉⦇ArrMap⦈⦇g ∘⇩A⇘op_smc 𝔄⇙ f⦈"
by
(
force
intro: is_semifunctor.smcf_ArrMap_Comp[OF assms(2), symmetric]
simp: slicing_simps smc_op_simps
)
from assms show ?thesis
unfolding gf by (cs_concl cs_simp: smc_op_simps)
qed
lemma smcf_eqI:
assumes "𝔊 : 𝔄 ↦↦⇩S⇩M⇩C⇘α⇙ 𝔅"
and "𝔉 : ℭ ↦↦⇩S⇩M⇩C⇘α⇙ 𝔇"
and "𝔊⦇ObjMap⦈ = 𝔉⦇ObjMap⦈"
and "𝔊⦇ArrMap⦈ = 𝔉⦇ArrMap⦈"
and "𝔄 = ℭ"
and "𝔅 = 𝔇"
shows "𝔊 = 𝔉"
proof-
interpret L: is_semifunctor α 𝔄 𝔅 𝔊 by (rule assms(1))
interpret R: is_semifunctor α ℭ 𝔇 𝔉 by (rule assms(2))
show ?thesis
proof(rule vsv_eqI)
have dom: "𝒟⇩∘ 𝔊 = 4⇩ℕ" by (cs_concl cs_simp: smc_cs_simps V_cs_simps)
show "𝒟⇩∘ 𝔊 = 𝒟⇩∘ 𝔉" by (cs_concl cs_simp: smc_cs_simps V_cs_simps)
from assms(5,6) have sup: "𝔊⦇HomDom⦈ = 𝔉⦇HomDom⦈" "𝔊⦇HomCod⦈ = 𝔉⦇HomCod⦈"
by (simp_all add: smc_cs_simps)
show "a ∈⇩∘ 𝒟⇩∘ 𝔊 ⟹ 𝔊⦇a⦈ = 𝔉⦇a⦈" for a
by (unfold dom, elim_in_numeral, insert assms(3,4) sup)
(auto simp: dghm_field_simps)
qed auto
qed
lemma smcf_dghm_eqI:
assumes "𝔊 : 𝔄 ↦↦⇩S⇩M⇩C⇘α⇙ 𝔅"
and "𝔉 : ℭ ↦↦⇩S⇩M⇩C⇘α⇙ 𝔇"
and "𝔄 = ℭ"
and "𝔅 = 𝔇"
and "smcf_dghm 𝔊 = smcf_dghm 𝔉"
shows "𝔊 = 𝔉"
proof(rule smcf_eqI)
from assms(5) have
"smcf_dghm 𝔊⦇ObjMap⦈ = smcf_dghm 𝔉⦇ObjMap⦈"
"smcf_dghm 𝔊⦇ArrMap⦈ = smcf_dghm 𝔉⦇ArrMap⦈"
by simp_all
then show "𝔊⦇ObjMap⦈ = 𝔉⦇ObjMap⦈" "𝔊⦇ArrMap⦈ = 𝔉⦇ArrMap⦈"
unfolding slicing_simps by simp_all
qed (auto intro: assms(1,2) simp: assms)
lemma (in is_semifunctor) smcf_def:
"𝔉 = [𝔉⦇ObjMap⦈, 𝔉⦇ArrMap⦈, 𝔉⦇HomDom⦈, 𝔉⦇HomCod⦈]⇩∘"
proof(rule vsv_eqI)
have dom_lhs: "𝒟⇩∘ 𝔉 = 4⇩ℕ" by (cs_concl cs_simp: smc_cs_simps V_cs_simps)
have dom_rhs: "𝒟⇩∘ [𝔉⦇Obj⦈, 𝔉⦇Arr⦈, 𝔉⦇Dom⦈, 𝔉⦇Cod⦈]⇩∘ = 4⇩ℕ"
by (simp add: nat_omega_simps)
then show "𝒟⇩∘ 𝔉 = 𝒟⇩∘ [𝔉⦇ObjMap⦈, 𝔉⦇ArrMap⦈, 𝔉⦇HomDom⦈, 𝔉⦇HomCod⦈]⇩∘"
unfolding dom_lhs dom_rhs by (simp add: nat_omega_simps)
show "a ∈⇩∘ 𝒟⇩∘ 𝔉 ⟹ 𝔉⦇a⦈ = [𝔉⦇ObjMap⦈, 𝔉⦇ArrMap⦈, 𝔉⦇HomDom⦈, 𝔉⦇HomCod⦈]⇩∘⦇a⦈"
for a
by (unfold dom_lhs, elim_in_numeral, unfold dghm_field_simps)
(simp_all add: nat_omega_simps)
qed (auto simp: vsv_axioms)
lemma (in is_semifunctor) smcf_in_Vset:
assumes "𝒵 β" and "α ∈⇩∘ β"
shows "𝔉 ∈⇩∘ Vset β"
proof-
interpret β: 𝒵 β by (rule assms(1))
note [smc_cs_intros] =
smcf_ObjMap_in_Vset
smcf_ArrMap_in_Vset
HomDom.smc_in_Vset
HomCod.smc_in_Vset
from assms(2) show ?thesis
by (subst smcf_def)
(cs_concl cs_simp: smc_cs_simps cs_intro: smc_cs_intros V_cs_intros)
qed
lemma (in is_semifunctor) smcf_is_semifunctor_if_ge_Limit:
assumes "𝒵 β" and "α ∈⇩∘ β"
shows "𝔉 : 𝔄 ↦↦⇩S⇩M⇩C⇘β⇙ 𝔅"
by (rule is_semifunctorI)
(
simp_all add:
assms
vfsequence_axioms
smcf_is_dghm_if_ge_Limit
HomDom.smc_semicategory_if_ge_Limit
HomCod.smc_semicategory_if_ge_Limit
smc_cs_simps
)
lemma small_all_smcfs[simp]: "small {𝔉. ∃𝔄 𝔅. 𝔉 : 𝔄 ↦↦⇩S⇩M⇩C⇘α⇙ 𝔅}"
proof(cases ‹𝒵 α›)
case True
from is_semifunctor.smcf_in_Vset show ?thesis
by (intro down[of _ ‹Vset (α + ω)›])
(auto simp: True 𝒵.𝒵_Limit_αω 𝒵.𝒵_ω_αω 𝒵.intro 𝒵.𝒵_α_αω)
next
case False
then have "{𝔉. ∃𝔄 𝔅. 𝔉 : 𝔄 ↦↦⇩S⇩M⇩C⇘α⇙ 𝔅} = {}" by auto
then show ?thesis by simp
qed
lemma (in is_semifunctor) smcf_in_Vset_7: "𝔉 ∈⇩∘ Vset (α + 7⇩ℕ)"
proof-
note [folded VPow_iff, folded Vset_succ[OF Ord_α], smc_cs_intros] =
smcf_ObjMap_vsubset_Vset
smcf_ArrMap_vsubset_Vset
from HomDom.smc_semicategory_in_Vset_4 have [smc_cs_intros]:
"𝔄 ∈⇩∘ Vset (succ (succ (succ (succ α))))"
by (succ_of_numeral) (cs_prems cs_simp: plus_V_succ_right V_cs_simps)
from HomCod.smc_semicategory_in_Vset_4 have [smc_cs_intros]:
"𝔅 ∈⇩∘ Vset (succ (succ (succ (succ α))))"
by (succ_of_numeral) (cs_prems cs_simp: plus_V_succ_right V_cs_simps)
show ?thesis
by (subst smcf_def, succ_of_numeral)
(
cs_concl
cs_simp: plus_V_succ_right V_cs_simps smc_cs_simps
cs_intro: smc_cs_intros V_cs_intros
)
qed
lemma (in 𝒵) all_smcfs_in_Vset:
assumes "𝒵 β" and "α ∈⇩∘ β"
shows "all_smcfs α ∈⇩∘ Vset β"
proof(rule vsubset_in_VsetI)
interpret β: 𝒵 β by (rule assms(1))
show "all_smcfs α ⊆⇩∘ Vset (α + 7⇩ℕ)"
proof(intro vsubsetI)
fix 𝔉 assume "𝔉 ∈⇩∘ all_smcfs α"
then obtain 𝔄 𝔅 where 𝔉: "𝔉 : 𝔄 ↦↦⇩S⇩M⇩C⇘α⇙ 𝔅" by clarsimp
then interpret is_semifunctor α 𝔄 𝔅 𝔉 .
show "𝔉 ∈⇩∘ Vset (α + 7⇩ℕ)" by (rule smcf_in_Vset_7)
qed
from assms(2) show "Vset (α + 7⇩ℕ) ∈⇩∘ Vset β"
by (cs_concl cs_intro: V_cs_intros Ord_cs_intros)
qed
lemma small_smcfs[simp]: "small {𝔉. 𝔉 : 𝔄 ↦↦⇩S⇩M⇩C⇘α⇙ 𝔅}"
by (rule down[of _ ‹set {𝔉. ∃𝔄 𝔅. 𝔉 : 𝔄 ↦↦⇩S⇩M⇩C⇘α⇙ 𝔅}›]) auto
subsection‹Opposite semifunctor›
subsubsection‹Definition and elementary properties›
text‹See Chapter II-2 in \cite{mac_lane_categories_2010}.›
definition op_smcf :: "V ⇒ V"
where "op_smcf 𝔉 =
[𝔉⦇ObjMap⦈, 𝔉⦇ArrMap⦈, op_smc (𝔉⦇HomDom⦈), op_smc (𝔉⦇HomCod⦈)]⇩∘"
text‹Components.›
lemma op_smcf_components[smc_op_simps]:
shows "op_smcf 𝔉⦇ObjMap⦈ = 𝔉⦇ObjMap⦈"
and "op_smcf 𝔉⦇ArrMap⦈ = 𝔉⦇ArrMap⦈"
and "op_smcf 𝔉⦇HomDom⦈ = op_smc (𝔉⦇HomDom⦈)"
and "op_smcf 𝔉⦇HomCod⦈ = op_smc (𝔉⦇HomCod⦈)"
unfolding op_smcf_def dghm_field_simps by (auto simp: nat_omega_simps)
text‹Slicing.›
lemma op_dghm_smcf_dghm[slicing_commute]:
"op_dghm (smcf_dghm 𝔉) = smcf_dghm (op_smcf 𝔉)"
proof(rule vsv_eqI)
have dom_lhs: "𝒟⇩∘ (op_dghm (smcf_dghm 𝔉)) = 4⇩ℕ"
unfolding op_dghm_def by (auto simp: nat_omega_simps)
have dom_rhs: "𝒟⇩∘ (smcf_dghm (op_smcf 𝔉)) = 4⇩ℕ"
unfolding smcf_dghm_def by (auto simp: nat_omega_simps)
show "𝒟⇩∘ (op_dghm (smcf_dghm 𝔉)) = 𝒟⇩∘ (smcf_dghm (op_smcf 𝔉))"
unfolding dom_lhs dom_rhs by simp
show "a ∈⇩∘ 𝒟⇩∘ (op_dghm (smcf_dghm 𝔉)) ⟹
op_dghm (smcf_dghm 𝔉)⦇a⦈ = smcf_dghm (op_smcf 𝔉)⦇a⦈"
for a
by
(
unfold dom_lhs,
elim_in_numeral,
unfold smcf_dghm_def op_smcf_def op_dghm_def dghm_field_simps
)
(auto simp: nat_omega_simps slicing_simps slicing_commute)
qed (auto simp: smcf_dghm_def op_dghm_def)
subsubsection‹Further properties›
lemma (in is_semifunctor) is_semifunctor_op:
"op_smcf 𝔉 : op_smc 𝔄 ↦↦⇩S⇩M⇩C⇘α⇙ op_smc 𝔅"
proof(intro is_semifunctorI)
show "vfsequence (op_smcf 𝔉)" unfolding op_smcf_def by simp
show "vcard (op_smcf 𝔉) = 4⇩ℕ"
unfolding op_smcf_def by (auto simp: nat_omega_simps)
fix g b c f a assume "g : b ↦⇘op_smc 𝔄⇙ c" "f : a ↦⇘op_smc 𝔄⇙ b"
then have "g : c ↦⇘𝔄⇙ b" and "f : b ↦⇘𝔄⇙ a"
unfolding smc_op_simps by simp_all
with is_semifunctor_axioms show
"op_smcf 𝔉⦇ArrMap⦈⦇g ∘⇩A⇘op_smc 𝔄⇙ f⦈ =
op_smcf 𝔉⦇ArrMap⦈⦇g⦈ ∘⇩A⇘op_smc 𝔅⇙ op_smcf 𝔉⦇ArrMap⦈⦇f⦈"
by
(
cs_concl
cs_simp: smc_op_simps smc_cs_simps
cs_intro: smc_op_intros smc_cs_intros
)
qed
(
auto simp:
smc_cs_simps
smc_op_simps
slicing_simps
slicing_commute[symmetric]
is_dghm.is_dghm_op
smcf_is_dghm
HomCod.semicategory_op
HomDom.semicategory_op
)
lemma (in is_semifunctor) is_semifunctor_op':
assumes "𝔄' = op_smc 𝔄" and "𝔅' = op_smc 𝔅" and "α' = α"
shows "op_smcf 𝔉 : 𝔄' ↦↦⇩S⇩M⇩C⇘α'⇙ 𝔅'"
unfolding assms by (rule is_semifunctor_op)
lemmas is_semifunctor_op'[smc_op_intros] = is_semifunctor.is_semifunctor_op'
lemma (in is_semifunctor) smcf_op_smcf_op_smcf[smc_op_simps]:
"op_smcf (op_smcf 𝔉) = 𝔉"
proof(rule smcf_eqI, unfold smc_op_simps)
show "op_smcf (op_smcf 𝔉) : 𝔄 ↦↦⇩S⇩M⇩C⇘α⇙ 𝔅"
by
(
metis
HomCod.smc_op_smc_op_smc
HomDom.smc_op_smc_op_smc
is_semifunctor.is_semifunctor_op
is_semifunctor_op
)
qed (simp_all add: is_semifunctor_axioms)
lemmas smcf_op_smcf_op_smcf[smc_op_simps] = is_semifunctor.smcf_op_smcf_op_smcf
lemma eq_op_smcf_iff[smc_op_simps]:
assumes "𝔊 : 𝔄 ↦↦⇩S⇩M⇩C⇘α⇙ 𝔅" and "𝔉 : ℭ ↦↦⇩S⇩M⇩C⇘α⇙ 𝔇"
shows "op_smcf 𝔊 = op_smcf 𝔉 ⟷ 𝔊 = 𝔉"
proof
interpret L: is_semifunctor α 𝔄 𝔅 𝔊 by (rule assms(1))
interpret R: is_semifunctor α ℭ 𝔇 𝔉 by (rule assms(2))
assume prems: "op_smcf 𝔊 = op_smcf 𝔉"
show "𝔊 = 𝔉"
proof(rule smcf_eqI[OF assms])
from prems R.smcf_op_smcf_op_smcf L.smcf_op_smcf_op_smcf show
"𝔊⦇ObjMap⦈ = 𝔉⦇ObjMap⦈" and "𝔊⦇ArrMap⦈ = 𝔉⦇ArrMap⦈"
by metis+
from prems R.smcf_op_smcf_op_smcf L.smcf_op_smcf_op_smcf have
"𝔊⦇HomDom⦈ = 𝔉⦇HomDom⦈" "𝔊⦇HomCod⦈ = 𝔉⦇HomCod⦈"
by auto
then show "𝔄 = ℭ" "𝔅 = 𝔇" by (simp_all add: smc_cs_simps)
qed
qed auto
subsection‹Composition of covariant semifunctors›
subsubsection‹Definition and elementary properties›
abbreviation (input) smcf_comp :: "V ⇒ V ⇒ V" (infixl "∘⇩S⇩M⇩C⇩F" 55)
where "smcf_comp ≡ dghm_comp"
text‹Slicing.›
lemma smcf_dghm_smcf_comp[slicing_commute]:
"smcf_dghm 𝔊 ∘⇩D⇩G⇩H⇩M smcf_dghm 𝔉 = smcf_dghm (𝔊 ∘⇩S⇩M⇩C⇩F 𝔉)"
unfolding dghm_comp_def smcf_dghm_def dghm_field_simps
by (simp add: nat_omega_simps)
subsubsection‹Object map›
lemma smcf_comp_ObjMap_vsv[smc_cs_intros]:
assumes "𝔊 : 𝔅 ↦↦⇩S⇩M⇩C⇘α⇙ ℭ" and "𝔉 : 𝔄 ↦↦⇩S⇩M⇩C⇘α⇙ 𝔅"
shows "vsv ((𝔊 ∘⇩S⇩M⇩C⇩F 𝔉)⦇ObjMap⦈)"
proof-
interpret L: is_semifunctor α 𝔅 ℭ 𝔊 by (rule assms(1))
interpret R: is_semifunctor α 𝔄 𝔅 𝔉 by (rule assms(2))
show ?thesis
by
(
rule dghm_comp_ObjMap_vsv
[
OF L.smcf_is_dghm R.smcf_is_dghm,
unfolded slicing_simps slicing_commute
]
)
qed
lemma smcf_comp_ObjMap_vdomain[smc_cs_simps]:
assumes "𝔊 : 𝔅 ↦↦⇩S⇩M⇩C⇘α⇙ ℭ" and "𝔉 : 𝔄 ↦↦⇩S⇩M⇩C⇘α⇙ 𝔅"
shows "𝒟⇩∘ ((𝔊 ∘⇩S⇩M⇩C⇩F 𝔉)⦇ObjMap⦈) = 𝔄⦇Obj⦈"
proof-
interpret L: is_semifunctor α 𝔅 ℭ 𝔊 by (rule assms(1))
interpret R: is_semifunctor α 𝔄 𝔅 𝔉 by (rule assms(2))
show ?thesis
by
(
rule dghm_comp_ObjMap_vdomain
[
OF L.smcf_is_dghm R.smcf_is_dghm,
unfolded slicing_simps slicing_commute
]
)
qed
lemma smcf_comp_ObjMap_vrange:
assumes "𝔊 : 𝔅 ↦↦⇩S⇩M⇩C⇘α⇙ ℭ" and "𝔉 : 𝔄 ↦↦⇩S⇩M⇩C⇘α⇙ 𝔅"
shows "ℛ⇩∘ ((𝔊 ∘⇩S⇩M⇩C⇩F 𝔉)⦇ObjMap⦈) ⊆⇩∘ ℭ⦇Obj⦈"
proof-
interpret L: is_semifunctor α 𝔅 ℭ 𝔊 by (rule assms(1))
interpret R: is_semifunctor α 𝔄 𝔅 𝔉 by (rule assms(2))
show ?thesis
by
(
rule dghm_comp_ObjMap_vrange
[
OF L.smcf_is_dghm R.smcf_is_dghm,
unfolded slicing_simps slicing_commute
]
)
qed
lemma smcf_comp_ObjMap_app[smc_cs_simps]:
assumes "𝔊 : 𝔅 ↦↦⇩S⇩M⇩C⇘α⇙ ℭ"
and "𝔉 : 𝔄 ↦↦⇩S⇩M⇩C⇘α⇙ 𝔅"
and [simp]: "a ∈⇩∘ 𝔄⦇Obj⦈"
shows "(𝔊 ∘⇩S⇩M⇩C⇩F 𝔉)⦇ObjMap⦈⦇a⦈ = 𝔊⦇ObjMap⦈⦇𝔉⦇ObjMap⦈⦇a⦈⦈"
proof-
interpret L: is_semifunctor α 𝔅 ℭ 𝔊 by (rule assms(1))
interpret R: is_semifunctor α 𝔄 𝔅 𝔉 by (rule assms(2))
show ?thesis
by
(
rule dghm_comp_ObjMap_app
[
OF L.smcf_is_dghm R.smcf_is_dghm,
unfolded slicing_simps slicing_commute,
OF assms(3)
]
)
qed
subsubsection‹Arrow map›
lemma smcf_comp_ArrMap_vsv[smc_cs_intros]:
assumes "𝔊 : 𝔅 ↦↦⇩S⇩M⇩C⇘α⇙ ℭ" and "𝔉 : 𝔄 ↦↦⇩S⇩M⇩C⇘α⇙ 𝔅"
shows "vsv ((𝔊 ∘⇩S⇩M⇩C⇩F 𝔉)⦇ArrMap⦈)"
proof-
interpret L: is_semifunctor α 𝔅 ℭ 𝔊 by (rule assms(1))
interpret R: is_semifunctor α 𝔄 𝔅 𝔉 by (rule assms(2))
show ?thesis
by
(
rule dghm_comp_ArrMap_vsv
[
OF L.smcf_is_dghm R.smcf_is_dghm,
unfolded slicing_simps slicing_commute
]
)
qed
lemma smcf_comp_ArrMap_vdomain[smc_cs_simps]:
assumes "𝔊 : 𝔅 ↦↦⇩S⇩M⇩C⇘α⇙ ℭ" and "𝔉 : 𝔄 ↦↦⇩S⇩M⇩C⇘α⇙ 𝔅"
shows "𝒟⇩∘ ((𝔊 ∘⇩S⇩M⇩C⇩F 𝔉)⦇ArrMap⦈) = 𝔄⦇Arr⦈"
proof-
interpret L: is_semifunctor α 𝔅 ℭ 𝔊 by (rule assms(1))
interpret R: is_semifunctor α 𝔄 𝔅 𝔉 by (rule assms(2))
show ?thesis
by
(
rule dghm_comp_ArrMap_vdomain
[
OF L.smcf_is_dghm R.smcf_is_dghm,
unfolded slicing_simps slicing_commute
]
)
qed
lemma smcf_comp_ArrMap_vrange:
assumes "𝔊 : 𝔅 ↦↦⇩S⇩M⇩C⇘α⇙ ℭ" and "𝔉 : 𝔄 ↦↦⇩S⇩M⇩C⇘α⇙ 𝔅"
shows "ℛ⇩∘ ((𝔊 ∘⇩S⇩M⇩C⇩F 𝔉)⦇ArrMap⦈) ⊆⇩∘ ℭ⦇Arr⦈"
proof-
interpret L: is_semifunctor α 𝔅 ℭ 𝔊 by (rule assms(1))
interpret R: is_semifunctor α 𝔄 𝔅 𝔉 by (rule assms(2))
show ?thesis
by
(
rule dghm_comp_ArrMap_vrange
[
OF L.smcf_is_dghm R.smcf_is_dghm,
unfolded slicing_simps slicing_commute
]
)
qed
lemma smcf_comp_ArrMap_app[smc_cs_simps]:
assumes "𝔊 : 𝔅 ↦↦⇩S⇩M⇩C⇘α⇙ ℭ"
and "𝔉 : 𝔄 ↦↦⇩S⇩M⇩C⇘α⇙ 𝔅"
and [simp]: "f ∈⇩∘ 𝔄⦇Arr⦈"
shows "(𝔊 ∘⇩S⇩M⇩C⇩F 𝔉)⦇ArrMap⦈⦇f⦈ = 𝔊⦇ArrMap⦈⦇𝔉⦇ArrMap⦈⦇f⦈⦈"
proof-
interpret L: is_semifunctor α 𝔅 ℭ 𝔊 by (rule assms(1))
interpret R: is_semifunctor α 𝔄 𝔅 𝔉 by (rule assms(2))
show ?thesis
by
(
rule dghm_comp_ArrMap_app
[
OF L.smcf_is_dghm R.smcf_is_dghm,
unfolded slicing_simps slicing_commute,
OF assms(3)
]
)
qed
subsubsection‹Further properties›
lemma smcf_comp_is_semifunctor[smc_cs_intros]:
assumes "𝔊 : 𝔅 ↦↦⇩S⇩M⇩C⇘α⇙ ℭ" and "𝔉 : 𝔄 ↦↦⇩S⇩M⇩C⇘α⇙ 𝔅"
shows "𝔊 ∘⇩S⇩M⇩C⇩F 𝔉 : 𝔄 ↦↦⇩S⇩M⇩C⇘α⇙ ℭ"
proof-
interpret L: is_semifunctor α 𝔅 ℭ 𝔊 by (rule assms(1))
interpret R: is_semifunctor α 𝔄 𝔅 𝔉 by (rule assms(2))
show ?thesis
proof(rule is_semifunctorI, unfold dghm_comp_components(3,4))
show "vfsequence (𝔊 ∘⇩S⇩M⇩C⇩F 𝔉)" by (simp add: dghm_comp_def)
show "vcard (𝔊 ∘⇩S⇩M⇩C⇩F 𝔉) = 4⇩ℕ"
unfolding dghm_comp_def by (simp add: nat_omega_simps)
fix g b c f a assume "g : b ↦⇘𝔄⇙ c" "f : a ↦⇘𝔄⇙ b"
with assms show "(𝔊 ∘⇩S⇩M⇩C⇩F 𝔉)⦇ArrMap⦈⦇g ∘⇩A⇘𝔄⇙ f⦈ =
(𝔊 ∘⇩S⇩M⇩C⇩F 𝔉)⦇ArrMap⦈⦇g⦈ ∘⇩A⇘ℭ⇙ (𝔊 ∘⇩S⇩M⇩C⇩F 𝔉)⦇ArrMap⦈⦇f⦈"
by (cs_concl cs_simp: smc_cs_simps cs_intro: smc_cs_intros)
qed
(
auto
simp: slicing_commute[symmetric] smc_cs_simps smc_cs_intros
intro: dg_cs_intros slicing_intros
)
qed
lemma smcf_comp_assoc[smc_cs_simps]:
assumes "ℌ : ℭ ↦↦⇩S⇩M⇩C⇘α⇙ 𝔇"
and "𝔊 : 𝔅 ↦↦⇩S⇩M⇩C⇘α⇙ ℭ"
and "𝔉 : 𝔄 ↦↦⇩S⇩M⇩C⇘α⇙ 𝔅"
shows "(ℌ ∘⇩S⇩M⇩C⇩F 𝔊) ∘⇩S⇩M⇩C⇩F 𝔉 = ℌ ∘⇩S⇩M⇩C⇩F (𝔊 ∘⇩S⇩M⇩C⇩F 𝔉)"
proof(rule smcf_eqI[of α 𝔄 𝔇 _ 𝔄 𝔇])
interpret ℌ: is_semifunctor α ℭ 𝔇 ℌ by (rule assms(1))
interpret 𝔊: is_semifunctor α 𝔅 ℭ 𝔊 by (rule assms(2))
interpret 𝔉: is_semifunctor α 𝔄 𝔅 𝔉 by (rule assms(3))
from 𝔉.is_semifunctor_axioms 𝔊.is_semifunctor_axioms ℌ.is_semifunctor_axioms
show "ℌ ∘⇩S⇩M⇩C⇩F (𝔊 ∘⇩S⇩M⇩C⇩F 𝔉) : 𝔄 ↦↦⇩S⇩M⇩C⇘α⇙ 𝔇"
and "ℌ ∘⇩S⇩M⇩C⇩F 𝔊 ∘⇩S⇩M⇩C⇩F 𝔉 : 𝔄 ↦↦⇩S⇩M⇩C⇘α⇙ 𝔇"
by (auto intro: smc_cs_intros)
qed (simp_all add: dghm_comp_components vcomp_assoc)
lemma op_smcf_smcf_comp[smc_op_simps]:
"op_smcf (𝔊 ∘⇩S⇩M⇩C⇩F 𝔉) = op_smcf 𝔊 ∘⇩S⇩M⇩C⇩F op_smcf 𝔉"
unfolding dghm_comp_def op_smcf_def dghm_field_simps
by (simp add: nat_omega_simps)
subsection‹Composition of contravariant semifunctors›
subsubsection‹Definition and elementary properties›
text‹See section 1.2 in \cite{bodo_categories_1970}.›
definition smcf_cn_comp :: "V ⇒ V ⇒ V" (infixl ‹⇩S⇩M⇩C⇩F∘› 55)
where "𝔊 ⇩S⇩M⇩C⇩F∘ 𝔉 =
[
𝔊⦇ObjMap⦈ ∘⇩∘ 𝔉⦇ObjMap⦈,
𝔊⦇ArrMap⦈ ∘⇩∘ 𝔉⦇ArrMap⦈,
op_smc (𝔉⦇HomDom⦈),
𝔊⦇HomCod⦈
]⇩∘"
text‹Components.›
lemma smcf_cn_comp_components:
shows "(𝔊 ⇩S⇩M⇩C⇩F∘ 𝔉)⦇ObjMap⦈ = 𝔊⦇ObjMap⦈ ∘⇩∘ 𝔉⦇ObjMap⦈"
and "(𝔊 ⇩S⇩M⇩C⇩F∘ 𝔉)⦇ArrMap⦈ = 𝔊⦇ArrMap⦈ ∘⇩∘ 𝔉⦇ArrMap⦈"
and [smc_cn_cs_simps]: "(𝔊 ⇩S⇩M⇩C⇩F∘ 𝔉)⦇HomDom⦈ = op_smc (𝔉⦇HomDom⦈)"
and [smc_cn_cs_simps]: "(𝔊 ⇩S⇩M⇩C⇩F∘ 𝔉)⦇HomCod⦈ = 𝔊⦇HomCod⦈"
unfolding smcf_cn_comp_def dghm_field_simps by (simp_all add: nat_omega_simps)
text‹Slicing.›
lemma smcf_dghm_smcf_cn_comp[slicing_commute]:
"smcf_dghm 𝔊 ⇩D⇩G⇩H⇩M∘ smcf_dghm 𝔉 = smcf_dghm (𝔊 ⇩S⇩M⇩C⇩F∘ 𝔉)"
unfolding dghm_cn_comp_def smcf_cn_comp_def smcf_dghm_def
by (simp add: nat_omega_simps slicing_commute dghm_field_simps)
subsubsection‹Object map: two contravariant semifunctors›
lemma smcf_cn_comp_ObjMap_vsv[smc_cn_cs_intros]:
assumes "𝔊 : 𝔅 ⇩S⇩M⇩C↦↦⇘α⇙ ℭ" and "𝔉 : 𝔄 ⇩S⇩M⇩C↦↦⇘α⇙ 𝔅"
shows "vsv ((𝔊 ⇩S⇩M⇩C⇩F∘ 𝔉)⦇ObjMap⦈)"
proof-
interpret L: is_semifunctor α ‹op_smc 𝔅› ℭ 𝔊 by (rule assms(1))
interpret R: is_semifunctor α ‹op_smc 𝔄› 𝔅 𝔉 by (rule assms(2))
show ?thesis
by
(
rule dghm_cn_cov_comp_ObjMap_vsv
[
OF
L.smcf_is_dghm[unfolded slicing_commute[symmetric]]
R.smcf_is_dghm[unfolded slicing_commute[symmetric]],
unfolded slicing_commute slicing_simps
]
)
qed
lemma smcf_cn_comp_ObjMap_vdomain[smc_cn_cs_simps]:
assumes "𝔊 : 𝔅 ⇩S⇩M⇩C↦↦⇘α⇙ ℭ" and "𝔉 : 𝔄 ⇩S⇩M⇩C↦↦⇘α⇙ 𝔅"
shows "𝒟⇩∘ ((𝔊 ⇩S⇩M⇩C⇩F∘ 𝔉)⦇ObjMap⦈) = 𝔄⦇Obj⦈"
proof-
interpret L: is_semifunctor α ‹op_smc 𝔅› ℭ 𝔊 by (rule assms(1))
interpret R: is_semifunctor α ‹op_smc 𝔄› 𝔅 𝔉 by (rule assms(2))
show ?thesis
by
(
rule dghm_cn_comp_ObjMap_vdomain
[
OF
L.smcf_is_dghm[unfolded slicing_commute[symmetric]]
R.smcf_is_dghm[unfolded slicing_commute[symmetric]],
unfolded slicing_commute slicing_simps
]
)
qed
lemma smcf_cn_comp_ObjMap_vrange:
assumes "𝔊 : 𝔅 ⇩S⇩M⇩C↦↦⇘α⇙ ℭ" and "𝔉 : 𝔄 ⇩S⇩M⇩C↦↦⇘α⇙ 𝔅"
shows "ℛ⇩∘ ((𝔊 ⇩S⇩M⇩C⇩F∘ 𝔉)⦇ObjMap⦈) ⊆⇩∘ ℭ⦇Obj⦈"
proof-
interpret L: is_semifunctor α ‹op_smc 𝔅› ℭ 𝔊 by (rule assms(1))
interpret R: is_semifunctor α ‹op_smc 𝔄› 𝔅 𝔉 by (rule assms(2))
show ?thesis
by
(
rule dghm_cn_comp_ObjMap_vrange
[
OF
L.smcf_is_dghm[unfolded slicing_commute[symmetric]]
R.smcf_is_dghm[unfolded slicing_commute[symmetric]],
unfolded slicing_commute slicing_simps
]
)
qed
lemma smcf_cn_comp_ObjMap_app[smc_cn_cs_simps]:
assumes "𝔊 : 𝔅 ⇩S⇩M⇩C↦↦⇘α⇙ ℭ" and "𝔉 : 𝔄 ⇩S⇩M⇩C↦↦⇘α⇙ 𝔅" and "a ∈⇩∘ 𝔄⦇Obj⦈"
shows "(𝔊 ⇩S⇩M⇩C⇩F∘ 𝔉)⦇ObjMap⦈⦇a⦈ = 𝔊⦇ObjMap⦈⦇𝔉⦇ObjMap⦈⦇a⦈⦈"
proof-
interpret L: is_semifunctor α ‹op_smc 𝔅› ℭ 𝔊 by (rule assms(1))
interpret R: is_semifunctor α ‹op_smc 𝔄› 𝔅 𝔉 by (rule assms(2))
show ?thesis
by
(
rule dghm_cn_comp_ObjMap_app
[
OF
L.smcf_is_dghm[unfolded slicing_commute[symmetric]]
R.smcf_is_dghm[unfolded slicing_commute[symmetric]],
unfolded slicing_commute slicing_simps,
OF assms(3)
]
)
qed
subsubsection‹Arrow map: two contravariant semifunctors›
lemma smcf_cn_comp_ArrMap_vsv[smc_cn_cs_intros]:
assumes "𝔊 : 𝔅 ⇩S⇩M⇩C↦↦⇘α⇙ ℭ" and "𝔉 : 𝔄 ⇩S⇩M⇩C↦↦⇘α⇙ 𝔅"
shows "vsv ((𝔊 ⇩S⇩M⇩C⇩F∘ 𝔉)⦇ArrMap⦈)"
proof-
interpret L: is_semifunctor α ‹op_smc 𝔅› ℭ 𝔊 by (rule assms(1))
interpret R: is_semifunctor α ‹op_smc 𝔄› 𝔅 𝔉 by (rule assms(2))
show ?thesis
by
(
rule dghm_cn_cov_comp_ArrMap_vsv
[
OF
L.smcf_is_dghm[unfolded slicing_commute[symmetric]]
R.smcf_is_dghm[unfolded slicing_commute[symmetric]],
unfolded slicing_commute slicing_simps
]
)
qed
lemma smcf_cn_comp_ArrMap_vdomain[smc_cn_cs_simps]:
assumes "𝔊 : 𝔅 ⇩S⇩M⇩C↦↦⇘α⇙ ℭ" and "𝔉 : 𝔄 ⇩S⇩M⇩C↦↦⇘α⇙ 𝔅"
shows "𝒟⇩∘ ((𝔊 ⇩S⇩M⇩C⇩F∘ 𝔉)⦇ArrMap⦈) = 𝔄⦇Arr⦈"
proof-
interpret L: is_semifunctor α ‹op_smc 𝔅› ℭ 𝔊 by (rule assms(1))
interpret R: is_semifunctor α ‹op_smc 𝔄› 𝔅 𝔉 by (rule assms(2))
show ?thesis
by
(
rule dghm_cn_comp_ArrMap_vdomain
[
OF
L.smcf_is_dghm[unfolded slicing_commute[symmetric]]
R.smcf_is_dghm[unfolded slicing_commute[symmetric]],
unfolded slicing_commute slicing_simps
]
)
qed
lemma smcf_cn_comp_ArrMap_vrange:
assumes "𝔊 : 𝔅 ⇩S⇩M⇩C↦↦⇘α⇙ ℭ" and "𝔉 : 𝔄 ⇩S⇩M⇩C↦↦⇘α⇙ 𝔅"
shows "ℛ⇩∘ ((𝔊 ⇩S⇩M⇩C⇩F∘ 𝔉)⦇ArrMap⦈) ⊆⇩∘ ℭ⦇Arr⦈"
proof-
interpret L: is_semifunctor α ‹op_smc 𝔅› ℭ 𝔊 by (rule assms(1))
interpret R: is_semifunctor α ‹op_smc 𝔄› 𝔅 𝔉 by (rule assms(2))
show ?thesis
by
(
rule dghm_cn_comp_ArrMap_vrange
[
OF
L.smcf_is_dghm[unfolded slicing_commute[symmetric]]
R.smcf_is_dghm[unfolded slicing_commute[symmetric]],
unfolded slicing_commute slicing_simps
]
)
qed
lemma smcf_cn_comp_ArrMap_app[smc_cn_cs_simps]:
assumes "𝔊 : 𝔅 ⇩S⇩M⇩C↦↦⇘α⇙ ℭ" and "𝔉 : 𝔄 ⇩S⇩M⇩C↦↦⇘α⇙ 𝔅" and "a ∈⇩∘ 𝔄⦇Arr⦈"
shows "(𝔊 ⇩S⇩M⇩C⇩F∘ 𝔉)⦇ArrMap⦈⦇a⦈ = 𝔊⦇ArrMap⦈⦇𝔉⦇ArrMap⦈⦇a⦈⦈"
proof-
interpret L: is_semifunctor α ‹op_smc 𝔅› ℭ 𝔊 by (rule assms(1))
interpret R: is_semifunctor α ‹op_smc 𝔄› 𝔅 𝔉 by (rule assms(2))
show ?thesis
by
(
rule dghm_cn_comp_ArrMap_app
[
OF
L.smcf_is_dghm[unfolded slicing_commute[symmetric]]
R.smcf_is_dghm[unfolded slicing_commute[symmetric]],
unfolded slicing_commute slicing_simps,
OF assms(3)
]
)
qed
subsubsection‹Object map: contravariant and covariant semifunctors›
lemma smcf_cn_cov_comp_ObjMap_vsv[smc_cn_cs_intros]:
assumes "𝔊 : 𝔅 ⇩S⇩M⇩C↦↦⇘α⇙ ℭ" and "𝔉 : 𝔄 ↦↦⇩S⇩M⇩C⇘α⇙ 𝔅"
shows "vsv ((𝔊 ⇩S⇩M⇩C⇩F∘ 𝔉)⦇ObjMap⦈)"
proof-
interpret L: is_semifunctor α ‹op_smc 𝔅› ℭ 𝔊 by (rule assms(1))
interpret R: is_semifunctor α 𝔄 𝔅 𝔉 by (rule assms(2))
show ?thesis
by
(
rule dghm_cn_cov_comp_ObjMap_vsv
[
OF
L.smcf_is_dghm[unfolded slicing_commute[symmetric]]
R.smcf_is_dghm[unfolded slicing_commute[symmetric]],
unfolded slicing_commute slicing_simps
]
)
qed
lemma smcf_cn_cov_comp_ObjMap_vdomain[smc_cn_cs_simps]:
assumes "𝔊 : 𝔅 ⇩S⇩M⇩C↦↦⇘α⇙ ℭ" and "𝔉 : 𝔄 ↦↦⇩S⇩M⇩C⇘α⇙ 𝔅"
shows "𝒟⇩∘ ((𝔊 ⇩S⇩M⇩C⇩F∘ 𝔉)⦇ObjMap⦈) = 𝔄⦇Obj⦈"
proof-
interpret L: is_semifunctor α ‹op_smc 𝔅› ℭ 𝔊 by (rule assms(1))
interpret R: is_semifunctor α 𝔄 𝔅 𝔉 by (rule assms(2))
show ?thesis
by
(
rule dghm_cn_cov_comp_ObjMap_vdomain
[
OF
L.smcf_is_dghm[unfolded slicing_commute[symmetric]]
R.smcf_is_dghm,
unfolded slicing_commute slicing_simps
]
)
qed
lemma smcf_cn_cov_comp_ObjMap_vrange:
assumes "𝔊 : 𝔅 ⇩S⇩M⇩C↦↦⇘α⇙ ℭ" and "𝔉 : 𝔄 ↦↦⇩S⇩M⇩C⇘α⇙ 𝔅"
shows "ℛ⇩∘ ((𝔊 ⇩S⇩M⇩C⇩F∘ 𝔉)⦇ObjMap⦈) ⊆⇩∘ ℭ⦇Obj⦈"
proof-
interpret L: is_semifunctor α ‹op_smc 𝔅› ℭ 𝔊 by (rule assms(1))
interpret R: is_semifunctor α 𝔄 𝔅 𝔉 by (rule assms(2))
show ?thesis
by
(
rule dghm_cn_cov_comp_ObjMap_vrange
[
OF
L.smcf_is_dghm[unfolded slicing_commute[symmetric]]
R.smcf_is_dghm,
unfolded slicing_commute slicing_simps
]
)
qed
lemma smcf_cn_cov_comp_ObjMap_app[smc_cn_cs_simps]:
assumes "𝔊 : 𝔅 ⇩S⇩M⇩C↦↦⇘α⇙ ℭ" and "𝔉 : 𝔄 ↦↦⇩S⇩M⇩C⇘α⇙ 𝔅" and "a ∈⇩∘ 𝔄⦇Obj⦈"
shows "(𝔊 ⇩S⇩M⇩C⇩F∘ 𝔉)⦇ObjMap⦈⦇a⦈ = 𝔊⦇ObjMap⦈⦇𝔉⦇ObjMap⦈⦇a⦈⦈"
proof-
interpret L: is_semifunctor α ‹op_smc 𝔅› ℭ 𝔊 by (rule assms(1))
interpret R: is_semifunctor α 𝔄 𝔅 𝔉 by (rule assms(2))
show ?thesis
by
(
rule dghm_cn_cov_comp_ObjMap_app
[
OF
L.smcf_is_dghm[unfolded slicing_commute[symmetric]]
R.smcf_is_dghm,
unfolded slicing_commute slicing_simps,
OF assms(3)
]
)
qed
subsubsection‹Arrow map: contravariant and covariant semifunctors›
lemma smcf_cn_cov_comp_ArrMap_vsv[smc_cn_cs_intros]:
assumes "𝔊 : 𝔅 ⇩S⇩M⇩C↦↦⇘α⇙ ℭ" and "𝔉 : 𝔄 ↦↦⇩S⇩M⇩C⇘α⇙ 𝔅"
shows "vsv ((𝔊 ⇩S⇩M⇩C⇩F∘ 𝔉)⦇ArrMap⦈)"
proof-
interpret L: is_semifunctor α ‹op_smc 𝔅› ℭ 𝔊 by (rule assms(1))
interpret R: is_semifunctor α 𝔄 𝔅 𝔉 by (rule assms(2))
show ?thesis
by
(
rule dghm_cn_cov_comp_ArrMap_vsv
[
OF
L.smcf_is_dghm[unfolded slicing_commute[symmetric]]
R.smcf_is_dghm[unfolded slicing_commute[symmetric]],
unfolded slicing_commute slicing_simps
]
)
qed
lemma smcf_cn_cov_comp_ArrMap_vdomain[smc_cn_cs_simps]:
assumes "𝔊 : 𝔅 ⇩S⇩M⇩C↦↦⇘α⇙ ℭ" and "𝔉 : 𝔄 ↦↦⇩S⇩M⇩C⇘α⇙ 𝔅"
shows "𝒟⇩∘ ((𝔊 ⇩S⇩M⇩C⇩F∘ 𝔉)⦇ArrMap⦈) = 𝔄⦇Arr⦈"
proof-
interpret L: is_semifunctor α ‹op_smc 𝔅› ℭ 𝔊 by (rule assms(1))
interpret R: is_semifunctor α 𝔄 𝔅 𝔉 by (rule assms(2))
show ?thesis
by
(
rule dghm_cn_cov_comp_ArrMap_vdomain
[
OF
L.smcf_is_dghm[unfolded slicing_commute[symmetric]]
R.smcf_is_dghm,
unfolded slicing_commute slicing_simps
]
)
qed
lemma smcf_cn_cov_comp_ArrMap_vrange:
assumes "𝔊 : 𝔅 ⇩S⇩M⇩C↦↦⇘α⇙ ℭ" and "𝔉 : 𝔄 ↦↦⇩S⇩M⇩C⇘α⇙ 𝔅"
shows "ℛ⇩∘ ((𝔊 ⇩S⇩M⇩C⇩F∘ 𝔉)⦇ArrMap⦈) ⊆⇩∘ ℭ⦇Arr⦈"
proof-
interpret L: is_semifunctor α ‹op_smc 𝔅› ℭ 𝔊 by (rule assms(1))
interpret R: is_semifunctor α 𝔄 𝔅 𝔉 by (rule assms(2))
show ?thesis
by
(
rule dghm_cn_cov_comp_ArrMap_vrange
[
OF
L.smcf_is_dghm[unfolded slicing_commute[symmetric]]
R.smcf_is_dghm,
unfolded slicing_commute slicing_simps
]
)
qed
lemma smcf_cn_cov_comp_ArrMap_app[smc_cn_cs_simps]:
assumes "𝔊 : 𝔅 ⇩S⇩M⇩C↦↦⇘α⇙ ℭ" and "𝔉 : 𝔄 ↦↦⇩S⇩M⇩C⇘α⇙ 𝔅" and "f ∈⇩∘ 𝔄⦇Arr⦈"
shows "(𝔊 ⇩S⇩M⇩C⇩F∘ 𝔉)⦇ArrMap⦈⦇f⦈ = 𝔊⦇ArrMap⦈⦇𝔉⦇ArrMap⦈⦇f⦈⦈"
proof-
interpret L: is_semifunctor α ‹op_smc 𝔅› ℭ 𝔊 by (rule assms(1))
interpret R: is_semifunctor α 𝔄 𝔅 𝔉 by (rule assms(2))
show ?thesis
by
(
rule dghm_cn_cov_comp_ArrMap_app
[
OF
L.smcf_is_dghm[unfolded slicing_commute[symmetric]]
R.smcf_is_dghm,
unfolded slicing_commute slicing_simps,
OF assms(3)
]
)
qed
subsubsection‹Opposite of the contravariant composition of semifunctors›
lemma op_smcf_smcf_cn_comp[smc_op_simps]:
"op_smcf (𝔊 ⇩S⇩M⇩C⇩F∘ 𝔉) = op_smcf 𝔊 ⇩S⇩M⇩C⇩F∘ op_smcf 𝔉"
unfolding op_smcf_def smcf_cn_comp_def dghm_field_simps
by (auto simp: nat_omega_simps)
subsubsection‹Further properties›
lemma smcf_cn_comp_is_semifunctor[smc_cn_cs_intros]:
assumes "semicategory α 𝔄" and "𝔊 : 𝔅 ⇩S⇩M⇩C↦↦⇘α⇙ ℭ" and "𝔉 : 𝔄 ⇩S⇩M⇩C↦↦⇘α⇙ 𝔅"
shows "𝔊 ⇩S⇩M⇩C⇩F∘ 𝔉 : 𝔄 ↦↦⇩S⇩M⇩C⇘α⇙ ℭ"
proof-
interpret L: is_semifunctor α ‹op_smc 𝔅› ℭ 𝔊
rewrites "f : b ↦⇘op_smc ℭ'⇙ a = f : a ↦⇘ℭ'⇙ b" for ℭ' f b a
by (rule assms(2)) (simp_all add: smc_op_simps)
interpret R: is_semifunctor α ‹op_smc 𝔄› 𝔅 𝔉
rewrites "f : b ↦⇘op_smc ℭ'⇙ a = f : a ↦⇘ℭ'⇙ b" for ℭ' f b a
by (rule assms(3)) (simp_all add: smc_op_simps)
interpret 𝔄: semicategory α 𝔄 by (rule assms(1))
show ?thesis
proof(rule is_semifunctorI, unfold smcf_cn_comp_components(3,4) smc_op_simps)
from assms show "smcf_dghm (𝔊 ⇩S⇩M⇩C⇩F∘ 𝔉) : smc_dg 𝔄 ↦↦⇩D⇩G⇘α⇙ smc_dg ℭ"
by
(
cs_concl
cs_simp: slicing_commute[symmetric]
cs_intro: dg_cn_cs_intros slicing_intros
)
fix g b c f a assume "g : b ↦⇘𝔄⇙ c" "f : a ↦⇘𝔄⇙ b"
with assms show "(𝔊 ⇩S⇩M⇩C⇩F∘ 𝔉)⦇ArrMap⦈⦇g ∘⇩A⇘𝔄⇙ f⦈ =
(𝔊 ⇩S⇩M⇩C⇩F∘ 𝔉)⦇ArrMap⦈⦇g⦈ ∘⇩A⇘ℭ⇙ (𝔊 ⇩S⇩M⇩C⇩F∘ 𝔉)⦇ArrMap⦈⦇f⦈"
by
(
cs_concl
cs_simp: smc_cs_simps smc_cn_cs_simps smc_op_simps
cs_intro: smc_cs_intros
)
qed
(
auto simp:
smcf_cn_comp_def
nat_omega_simps
smc_cs_simps
smc_op_simps
smc_cs_intros
)
qed
lemma smcf_cn_cov_comp_is_semifunctor[smc_cs_intros]:
assumes "𝔊 : 𝔅 ⇩S⇩M⇩C↦↦⇘α⇙ ℭ" and "𝔉 : 𝔄 ↦↦⇩S⇩M⇩C⇘α⇙ 𝔅"
shows "𝔊 ⇩S⇩M⇩C⇩F∘ 𝔉 : 𝔄 ⇩S⇩M⇩C↦↦⇘α⇙ ℭ"
proof-
interpret L: is_semifunctor α ‹op_smc 𝔅› ℭ 𝔊
rewrites "f : b ↦⇘op_smc ℭ'⇙ a = f : a ↦⇘ℭ'⇙ b" for ℭ' f b a
by (rule assms(1)) (simp_all add: smc_op_simps)
interpret R: is_semifunctor α 𝔄 𝔅 𝔉 by (rule assms(2))
show ?thesis
proof(rule is_semifunctorI, unfold smcf_cn_comp_components(3,4) smc_op_simps)
from assms show
"smcf_dghm (𝔊 ⇩S⇩M⇩C⇩F∘ 𝔉) : smc_dg (op_smc 𝔄) ↦↦⇩D⇩G⇘α⇙ smc_dg ℭ"
by
(
cs_concl
cs_simp: slicing_commute[symmetric]
cs_intro: dg_cn_cs_intros slicing_intros
)
show "vfsequence (𝔊 ⇩S⇩M⇩C⇩F∘ 𝔉)" unfolding smcf_cn_comp_def by simp
show "vcard (𝔊 ⇩S⇩M⇩C⇩F∘ 𝔉) = 4⇩ℕ"
unfolding smcf_cn_comp_def by (auto simp: nat_omega_simps)
show "op_smc (𝔉⦇HomDom⦈) = op_smc 𝔄" by (simp add: smc_cs_simps)
show "𝔊⦇HomCod⦈ = ℭ" by (simp add: smc_cs_simps)
fix g b c f a assume "g : c ↦⇘𝔄⇙ b" "f : b ↦⇘𝔄⇙ a"
with assms show
"(𝔊 ⇩S⇩M⇩C⇩F∘ 𝔉)⦇ArrMap⦈⦇f ∘⇩A⇘𝔄⇙ g⦈ =
(𝔊 ⇩S⇩M⇩C⇩F∘ 𝔉)⦇ArrMap⦈⦇g⦈ ∘⇩A⇘ℭ⇙ (𝔊 ⇩S⇩M⇩C⇩F∘ 𝔉)⦇ArrMap⦈⦇f⦈"
by
(
cs_concl
cs_simp: smc_cs_simps smc_cn_cs_simps smc_op_simps
cs_intro: smc_cs_intros
)
qed (auto intro: smc_cs_intros smc_op_intros)
qed
lemma smcf_cov_cn_comp_is_semifunctor[smc_cn_cs_intros]:
assumes "𝔊 : 𝔅 ↦↦⇩S⇩M⇩C⇘α⇙ ℭ" and "𝔉 : 𝔄 ⇩S⇩M⇩C↦↦⇘α⇙ 𝔅"
shows "𝔊 ∘⇩S⇩M⇩C⇩F 𝔉 : 𝔄 ⇩S⇩M⇩C↦↦⇘α⇙ ℭ"
using assms by (rule smcf_comp_is_semifunctor)
subsection‹Identity semifunctor›
subsubsection‹Definition and elementary properties›
text‹See Chapter I-3 in \cite{mac_lane_categories_2010}.›
abbreviation (input) smcf_id :: "V ⇒ V" where "smcf_id ≡ dghm_id"
text‹Slicing.›
lemma smcf_dghm_smcf_id[slicing_commute]:
"dghm_id (smc_dg ℭ) = smcf_dghm (smcf_id ℭ)"
unfolding dghm_id_def smc_dg_def smcf_dghm_def dghm_field_simps dg_field_simps
by (simp add: nat_omega_simps)
context semicategory
begin
interpretation dg: digraph α ‹smc_dg ℭ› by (rule smc_digraph)
lemmas_with [unfolded slicing_simps]:
smc_dghm_id_is_dghm = dg.dg_dghm_id_is_dghm
end
subsubsection‹Object map›
lemmas [smc_cs_simps] = dghm_id_ObjMap_app
subsubsection‹Arrow map›
lemmas [smc_cs_simps] = dghm_id_ArrMap_app
subsubsection‹Opposite identity semifunctor›
lemma op_smcf_smcf_id[smc_op_simps]: "op_smcf (smcf_id ℭ) = smcf_id (op_smc ℭ)"
unfolding dghm_id_def op_smc_def op_smcf_def dghm_field_simps dg_field_simps
by (auto simp: nat_omega_simps)
subsubsection‹An identity semifunctor is a semifunctor›
lemma (in semicategory) smc_smcf_id_is_semifunctor: "smcf_id ℭ : ℭ ↦↦⇩S⇩M⇩C⇘α⇙ ℭ"
proof(rule is_semifunctorI, unfold dghm_id_components)
from smc_dghm_id_is_dghm show
"smcf_dghm (smcf_id ℭ) : smc_dg ℭ ↦↦⇩D⇩G⇘α⇙ smc_dg ℭ"
by (auto simp: slicing_simps slicing_commute)
fix g b c f a assume "g : b ↦⇘ℭ⇙ c" "f : a ↦⇘ℭ⇙ b"
then show "vid_on (ℭ⦇Arr⦈)⦇g ∘⇩A⇘ℭ⇙ f⦈ =
vid_on (ℭ⦇Arr⦈)⦇g⦈ ∘⇩A⇘ℭ⇙ vid_on (ℭ⦇Arr⦈)⦇f⦈"
by (metis smc_is_arrD(1) smc_Comp_is_arr vid_on_eq_atI)
qed (auto simp: semicategory_axioms dghm_id_def nat_omega_simps)
lemma (in semicategory) smc_smcf_id_is_semifunctor':
assumes "𝔄 = ℭ" and "𝔅 = ℭ"
shows "smcf_id ℭ : 𝔄 ↦↦⇩S⇩M⇩C⇘α⇙ 𝔅"
unfolding assms by (rule smc_smcf_id_is_semifunctor)
lemmas [smc_cs_intros] = semicategory.smc_smcf_id_is_semifunctor'
subsubsection‹Further properties›
lemma (in is_semifunctor) smcf_smcf_comp_smcf_id_left[smc_cs_simps]:
"smcf_id 𝔅 ∘⇩S⇩M⇩C⇩F 𝔉 = 𝔉"
by (rule smcf_eqI, unfold dghm_id_components dghm_comp_components)
(auto simp: smcf_ObjMap_vrange smcf_ArrMap_vrange intro: smc_cs_intros)
lemmas [smc_cs_simps] = is_semifunctor.smcf_smcf_comp_smcf_id_left
lemma (in is_semifunctor) smcf_smcf_comp_smcf_id_right[smc_cs_simps]:
"𝔉 ∘⇩S⇩M⇩C⇩F smcf_id 𝔄 = 𝔉"
by (rule smcf_eqI, unfold dghm_id_components dghm_comp_components)
(
auto
simp: smcf_ObjMap_vrange smcf_ArrMap_vrange smc_cs_simps
intro: smc_cs_intros
)
lemmas [smc_cs_simps] = is_semifunctor.smcf_smcf_comp_smcf_id_right
subsection‹Constant semifunctor›
subsubsection‹Definition and elementary properties›
text‹See Chapter III-3 in \cite{mac_lane_categories_2010}.›
abbreviation (input) smcf_const :: "V ⇒ V ⇒ V ⇒ V ⇒ V"
where "smcf_const ≡ dghm_const"
text‹Slicing.›
lemma smcf_dghm_smcf_const[slicing_commute]:
"dghm_const (smc_dg ℭ) (smc_dg 𝔇) a f = smcf_dghm (smcf_const ℭ 𝔇 a f)"
unfolding
dghm_const_def smc_dg_def smcf_dghm_def dghm_field_simps dg_field_simps
by (simp add: nat_omega_simps)
subsubsection‹Object map›
lemmas [smc_cs_simps] =
dghm_const_ObjMap_app
subsubsection‹Arrow map›
lemmas [smc_cs_simps] =
dghm_const_ArrMap_app
subsubsection‹Opposite constant semifunctor›
lemma op_smcf_smcf_const[smc_op_simps]:
"op_smcf (smcf_const ℭ 𝔇 a f) = smcf_const (op_smc ℭ) (op_smc 𝔇) a f"
unfolding dghm_const_def op_smc_def op_smcf_def dghm_field_simps dg_field_simps
by (auto simp: nat_omega_simps)
subsubsection‹A constant semifunctor is a semifunctor›
lemma smcf_const_is_semifunctor:
assumes "semicategory α ℭ"
and "semicategory α 𝔇"
and "f : a ↦⇘𝔇⇙ a"
and [simp]: "f ∘⇩A⇘𝔇⇙ f = f"
shows "smcf_const ℭ 𝔇 a f : ℭ ↦↦⇩S⇩M⇩C⇘α⇙ 𝔇"
proof-
interpret ℭ: semicategory α ℭ by (rule assms(1))
interpret 𝔇: semicategory α 𝔇 by (rule assms(2))
show ?thesis
proof(intro is_semifunctorI, tactic‹distinct_subgoals_tac›)
from assms show
"smcf_dghm (dghm_const ℭ 𝔇 a f) : smc_dg ℭ ↦↦⇩D⇩G⇘α⇙ smc_dg 𝔇"
by
(
cs_concl
cs_simp: slicing_commute[symmetric]
cs_intro: dg_cs_intros slicing_intros
)
show "vfsequence (smcf_const ℭ 𝔇 a f)" unfolding dghm_const_def by simp
show "vcard (smcf_const ℭ 𝔇 a f) = 4⇩ℕ"
unfolding dghm_const_def by (simp add: nat_omega_simps)
fix g' b c f' a' assume "g' : b ↦⇘ℭ⇙ c" "f' : a' ↦⇘ℭ⇙ b"
with assms(1-3) show "smcf_const ℭ 𝔇 a f⦇ArrMap⦈⦇g' ∘⇩A⇘ℭ⇙ f'⦈ =
smcf_const ℭ 𝔇 a f⦇ArrMap⦈⦇g'⦈ ∘⇩A⇘𝔇⇙ smcf_const ℭ 𝔇 a f⦇ArrMap⦈⦇f'⦈"
by (cs_concl cs_simp: assms(4) smc_cs_simps cs_intro: smc_cs_intros)
qed (auto simp: assms(1,2) dghm_const_components)
qed
lemma smcf_const_is_semifunctor'[smc_cs_intros]:
assumes "semicategory α ℭ"
and "semicategory α 𝔇"
and "f : a ↦⇘𝔇⇙ a"
and "f ∘⇩A⇘𝔇⇙ f = f"
and "𝔄 = ℭ"
and "𝔅 = 𝔇"
shows "smcf_const ℭ 𝔇 a f : 𝔄 ↦↦⇩S⇩M⇩C⇘α⇙ 𝔅"
using assms(1-4) unfolding assms(5,6) by (rule smcf_const_is_semifunctor)
subsection‹Faithful semifunctor›
subsubsection‹Definition and elementary properties›
text‹See Chapter I-3 in \cite{mac_lane_categories_2010}.›
locale is_ft_semifunctor = is_semifunctor α 𝔄 𝔅 𝔉 for α 𝔄 𝔅 𝔉 +
assumes ft_smcf_is_ft_dghm:
"smcf_dghm 𝔉 : smc_dg 𝔄 ↦↦⇩D⇩G⇩.⇩f⇩a⇩i⇩t⇩h⇩f⇩u⇩l⇘α⇙ smc_dg 𝔅"
syntax "_is_ft_semifunctor" :: "V ⇒ V ⇒ V ⇒ V ⇒ bool"
(‹(_ :/ _ ↦↦⇩S⇩M⇩C⇩.⇩f⇩a⇩i⇩t⇩h⇩f⇩u⇩lı _)› [51, 51, 51] 51)
translations "𝔉 : 𝔄 ↦↦⇩S⇩M⇩C⇩.⇩f⇩a⇩i⇩t⇩h⇩f⇩u⇩l⇘α⇙ 𝔅" ⇌ "CONST is_ft_semifunctor α 𝔄 𝔅 𝔉"
lemma (in is_ft_semifunctor) ft_smcf_is_ft_dghm'[slicing_intros]:
assumes "𝔄' = smc_dg 𝔄" and "𝔅' = smc_dg 𝔅"
shows "smcf_dghm 𝔉 : 𝔄' ↦↦⇩D⇩G⇩.⇩f⇩a⇩i⇩t⇩h⇩f⇩u⇩l⇘α⇙ 𝔅'"
unfolding assms by (rule ft_smcf_is_ft_dghm)
lemmas [slicing_intros] = is_ft_semifunctor.ft_smcf_is_ft_dghm'
text‹Rules.›
lemma (in is_ft_semifunctor) is_ft_semifunctor_axioms'[smcf_cs_intros]:
assumes "α' = α" and "𝔄' = 𝔄" and "𝔅' = 𝔅"
shows "𝔉 : 𝔄' ↦↦⇩S⇩M⇩C⇩.⇩f⇩a⇩i⇩t⇩h⇩f⇩u⇩l⇘α'⇙ 𝔅'"
unfolding assms by (rule is_ft_semifunctor_axioms)
mk_ide rf is_ft_semifunctor_def[unfolded is_ft_semifunctor_axioms_def]
|intro is_ft_semifunctorI|
|dest is_ft_semifunctorD[dest]|
|elim is_ft_semifunctorE[elim]|
lemmas [smcf_cs_intros] = is_ft_semifunctorD(1)
lemma is_ft_semifunctorI':
assumes "𝔉 : 𝔄 ↦↦⇩S⇩M⇩C⇘α⇙ 𝔅"
and "⋀a b. ⟦ a ∈⇩∘ 𝔄⦇Obj⦈; b ∈⇩∘ 𝔄⦇Obj⦈ ⟧ ⟹ v11 (𝔉⦇ArrMap⦈ ↾⇧l⇩∘ Hom 𝔄 a b)"
shows "𝔉 : 𝔄 ↦↦⇩S⇩M⇩C⇩.⇩f⇩a⇩i⇩t⇩h⇩f⇩u⇩l⇘α⇙ 𝔅"
using assms
by (intro is_ft_semifunctorI)
(
simp_all add:
assms(1)
is_ft_dghmI[OF is_semifunctorD(6)[OF assms(1)], unfolded slicing_simps]
)
lemma is_ft_semifunctorD':
assumes "𝔉 : 𝔄 ↦↦⇩S⇩M⇩C⇩.⇩f⇩a⇩i⇩t⇩h⇩f⇩u⇩l⇘α⇙ 𝔅"
shows "𝔉 : 𝔄 ↦↦⇩S⇩M⇩C⇘α⇙ 𝔅"
and "⋀a b. ⟦ a ∈⇩∘ 𝔄⦇Obj⦈; b ∈⇩∘ 𝔄⦇Obj⦈ ⟧ ⟹ v11 (𝔉⦇ArrMap⦈ ↾⇧l⇩∘ Hom 𝔄 a b)"
by
(
simp_all add:
is_ft_semifunctorD[OF assms(1)]
is_ft_dghmD(2)[
OF is_ft_semifunctorD(2)[OF assms(1)], unfolded slicing_simps
]
)
lemma is_ft_semifunctorE':
assumes "𝔉 : 𝔄 ↦↦⇩S⇩M⇩C⇩.⇩f⇩a⇩i⇩t⇩h⇩f⇩u⇩l⇘α⇙ 𝔅"
obtains "𝔉 : 𝔄 ↦↦⇩S⇩M⇩C⇘α⇙ 𝔅"
and "⋀a b. ⟦ a ∈⇩∘ 𝔄⦇Obj⦈; b ∈⇩∘ 𝔄⦇Obj⦈ ⟧ ⟹ v11 (𝔉⦇ArrMap⦈ ↾⇧l⇩∘ Hom 𝔄 a b)"
using assms by (simp_all add: is_ft_semifunctorD')
text‹Elementary properties.›
context is_ft_semifunctor
begin
interpretation dghm: is_ft_dghm α ‹smc_dg 𝔄› ‹smc_dg 𝔅› ‹smcf_dghm 𝔉›
by (rule ft_smcf_is_ft_dghm)
lemmas_with [unfolded slicing_simps]:
ft_smcf_v11_on_Hom = dghm.ft_dghm_v11_on_Hom
end
subsubsection‹Opposite faithful semifunctor›
lemma (in is_ft_semifunctor) is_ft_semifunctor_op:
"op_smcf 𝔉 : op_smc 𝔄 ↦↦⇩S⇩M⇩C⇩.⇩f⇩a⇩i⇩t⇩h⇩f⇩u⇩l⇘α⇙ op_smc 𝔅"
by
(
rule is_ft_semifunctorI,
unfold smc_op_simps slicing_simps slicing_commute[symmetric]
)
(
simp_all add:
is_semifunctor_op is_ft_dghm.ft_dghm_op_dghm_is_ft_dghm
ft_smcf_is_ft_dghm
)
lemma (in is_ft_semifunctor) is_ft_semifunctor_op'[smc_op_intros]:
assumes "𝔄' = op_smc 𝔄" and "𝔅' = op_smc 𝔅"
shows "op_smcf 𝔉 : 𝔄' ↦↦⇩S⇩M⇩C⇩.⇩f⇩a⇩i⇩t⇩h⇩f⇩u⇩l⇘α⇙ 𝔅'"
unfolding assms by (rule is_ft_semifunctor_op)
lemmas is_ft_semifunctor_op[smc_op_intros] =
is_ft_semifunctor.is_ft_semifunctor_op'
subsubsection‹
The composition of faithful semifunctors is a faithful semifunctor
›
lemma smcf_comp_is_ft_semifunctor[smcf_cs_intros]:
assumes "𝔊 : 𝔅 ↦↦⇩S⇩M⇩C⇩.⇩f⇩a⇩i⇩t⇩h⇩f⇩u⇩l⇘α⇙ ℭ" and "𝔉 : 𝔄 ↦↦⇩S⇩M⇩C⇩.⇩f⇩a⇩i⇩t⇩h⇩f⇩u⇩l⇘α⇙ 𝔅"
shows "𝔊 ∘⇩S⇩M⇩C⇩F 𝔉 : 𝔄 ↦↦⇩S⇩M⇩C⇩.⇩f⇩a⇩i⇩t⇩h⇩f⇩u⇩l⇘α⇙ ℭ"
proof(intro is_ft_semifunctorI)
interpret 𝔊: is_ft_semifunctor α 𝔅 ℭ 𝔊 by (simp add: assms(1))
interpret 𝔉: is_ft_semifunctor α 𝔄 𝔅 𝔉 by (simp add: assms(2))
from 𝔉.is_semifunctor_axioms 𝔊.is_semifunctor_axioms show 𝔊𝔉:
"𝔊 ∘⇩S⇩M⇩C⇩F 𝔉 : 𝔄 ↦↦⇩S⇩M⇩C⇘α⇙ ℭ"
by (auto intro: smc_cs_intros)
then interpret is_semifunctor α 𝔄 ℭ ‹𝔊 ∘⇩S⇩M⇩C⇩F 𝔉› .
show "smcf_dghm (𝔊 ∘⇩S⇩M⇩C⇩F 𝔉) : smc_dg 𝔄 ↦↦⇩D⇩G⇩.⇩f⇩a⇩i⇩t⇩h⇩f⇩u⇩l⇘α⇙ smc_dg ℭ"
unfolding slicing_simps slicing_commute[symmetric]
by (auto intro: dghm_cs_intros slicing_intros)
qed
subsection‹Full semifunctor›
subsubsection‹Definition and elementary properties›
text‹See Chapter I-3 in \cite{mac_lane_categories_2010}.›
locale is_fl_semifunctor = is_semifunctor α 𝔄 𝔅 𝔉 for α 𝔄 𝔅 𝔉 +
assumes fl_smcf_is_fl_dghm:
"smcf_dghm 𝔉 : smc_dg 𝔄 ↦↦⇩D⇩G⇩.⇩f⇩u⇩l⇩l⇘α⇙ smc_dg 𝔅"
syntax "_is_fl_semifunctor" :: "V ⇒ V ⇒ V ⇒ V ⇒ bool"
(‹(_ :/ _ ↦↦⇩S⇩M⇩C⇩.⇩f⇩u⇩l⇩lı _)› [51, 51, 51] 51)
translations "𝔉 : 𝔄 ↦↦⇩S⇩M⇩C⇩.⇩f⇩u⇩l⇩l⇘α⇙ 𝔅" ⇌ "CONST is_fl_semifunctor α 𝔄 𝔅 𝔉"
lemma (in is_fl_semifunctor) fl_smcf_is_fl_dghm'[slicing_intros]:
assumes "𝔄' = smc_dg 𝔄" and "𝔅' = smc_dg 𝔅"
shows "smcf_dghm 𝔉 : 𝔄' ↦↦⇩D⇩G⇩.⇩f⇩u⇩l⇩l⇘α⇙ 𝔅'"
unfolding assms by (rule fl_smcf_is_fl_dghm)
lemmas [slicing_intros] = is_fl_semifunctor.fl_smcf_is_fl_dghm'
text‹Rules.›
mk_ide rf is_fl_semifunctor_def[unfolded is_fl_semifunctor_axioms_def]
|intro is_fl_semifunctorI|
|dest is_fl_semifunctorD[dest]|
|elim is_fl_semifunctorE[elim]|
lemmas [smcf_cs_intros] = is_fl_semifunctorD(1)
lemma is_fl_semifunctorI':
assumes "𝔉 : 𝔄 ↦↦⇩S⇩M⇩C⇘α⇙ 𝔅"
and "⋀a b. ⟦ a ∈⇩∘ 𝔄⦇Obj⦈; b ∈⇩∘ 𝔄⦇Obj⦈ ⟧ ⟹
𝔉⦇ArrMap⦈ `⇩∘ (Hom 𝔄 a b) = Hom 𝔅 (𝔉⦇ObjMap⦈⦇a⦈) (𝔉⦇ObjMap⦈⦇b⦈)"
shows "𝔉 : 𝔄 ↦↦⇩S⇩M⇩C⇩.⇩f⇩u⇩l⇩l⇘α⇙ 𝔅"
using assms
by (intro is_fl_semifunctorI)
(
simp_all add:
assms(1)
is_fl_dghmI[OF is_semifunctorD(6)[OF assms(1)], unfolded slicing_simps]
)
lemma is_fl_semifunctorD':
assumes "𝔉 : 𝔄 ↦↦⇩S⇩M⇩C⇩.⇩f⇩u⇩l⇩l⇘α⇙ 𝔅"
shows "𝔉 : 𝔄 ↦↦⇩S⇩M⇩C⇘α⇙ 𝔅"
and "⋀a b. ⟦ a ∈⇩∘ 𝔄⦇Obj⦈; b ∈⇩∘ 𝔄⦇Obj⦈ ⟧ ⟹
𝔉⦇ArrMap⦈ `⇩∘ (Hom 𝔄 a b) = Hom 𝔅 (𝔉⦇ObjMap⦈⦇a⦈) (𝔉⦇ObjMap⦈⦇b⦈)"
by
(
simp_all add:
is_fl_semifunctorD[OF assms(1)]
is_fl_dghmD(2)[
OF is_fl_semifunctorD(2)[OF assms(1)], unfolded slicing_simps
]
)
lemma is_fl_semifunctorE':
assumes "𝔉 : 𝔄 ↦↦⇩S⇩M⇩C⇩.⇩f⇩u⇩l⇩l⇘α⇙ 𝔅"
obtains "𝔉 : 𝔄 ↦↦⇩S⇩M⇩C⇘α⇙ 𝔅"
and "⋀a b. ⟦ a ∈⇩∘ 𝔄⦇Obj⦈; b ∈⇩∘ 𝔄⦇Obj⦈ ⟧ ⟹
𝔉⦇ArrMap⦈ `⇩∘ (Hom 𝔄 a b) = Hom 𝔅 (𝔉⦇ObjMap⦈⦇a⦈) (𝔉⦇ObjMap⦈⦇b⦈)"
using assms by (simp_all add: is_fl_semifunctorD')
text‹Elementary properties.›
context is_fl_semifunctor
begin
interpretation dghm: is_fl_dghm α ‹smc_dg 𝔄› ‹smc_dg 𝔅› ‹smcf_dghm 𝔉›
by (rule fl_smcf_is_fl_dghm)
lemmas_with [unfolded slicing_simps]:
fl_smcf_surj_on_Hom = dghm.fl_dghm_surj_on_Hom
end
subsubsection‹Opposite full semifunctor›
lemma (in is_fl_semifunctor) is_fl_semifunctor_op:
"op_smcf 𝔉 : op_smc 𝔄 ↦↦⇩S⇩M⇩C⇩.⇩f⇩u⇩l⇩l⇘α⇙ op_smc 𝔅"
by
(
rule is_fl_semifunctorI,
unfold smc_op_simps slicing_simps slicing_commute[symmetric]
)
(
simp_all add:
is_semifunctor_op
is_fl_dghm.fl_dghm_op_dghm_is_fl_dghm
fl_smcf_is_fl_dghm
)
lemma (in is_fl_semifunctor) is_fl_semifunctor_op'[smc_op_intros]:
assumes "𝔄' = op_smc 𝔄" and "𝔅' = op_smc 𝔅"
shows "op_smcf 𝔉 : 𝔄' ↦↦⇩S⇩M⇩C⇩.⇩f⇩u⇩l⇩l⇘α⇙ 𝔅'"
unfolding assms by (rule is_fl_semifunctor_op)
lemmas is_fl_semifunctor_op[smc_op_intros] =
is_fl_semifunctor.is_fl_semifunctor_op
subsubsection‹The composition of full semifunctors is a full semifunctor›
lemma smcf_comp_is_fl_semifunctor[smcf_cs_intros]:
assumes "𝔊 : 𝔅 ↦↦⇩S⇩M⇩C⇩.⇩f⇩u⇩l⇩l⇘α⇙ ℭ" and "𝔉 : 𝔄 ↦↦⇩S⇩M⇩C⇩.⇩f⇩u⇩l⇩l⇘α⇙ 𝔅"
shows "𝔊 ∘⇩S⇩M⇩C⇩F 𝔉 : 𝔄 ↦↦⇩S⇩M⇩C⇩.⇩f⇩u⇩l⇩l⇘α⇙ ℭ"
proof(intro is_fl_semifunctorI)
interpret 𝔉: is_fl_semifunctor α 𝔄 𝔅 𝔉 using assms(2) by simp
interpret 𝔊: is_fl_semifunctor α 𝔅 ℭ 𝔊 using assms(1) by simp
from 𝔉.is_semifunctor_axioms 𝔊.is_semifunctor_axioms show
"𝔊 ∘⇩S⇩M⇩C⇩F 𝔉 : 𝔄 ↦↦⇩S⇩M⇩C⇘α⇙ ℭ"
by (auto intro: smc_cs_intros)
show "smcf_dghm (𝔊 ∘⇩D⇩G⇩H⇩M 𝔉) : smc_dg 𝔄 ↦↦⇩D⇩G⇩.⇩f⇩u⇩l⇩l⇘α⇙ smc_dg ℭ"
unfolding slicing_commute[symmetric]
by (auto intro: dghm_cs_intros slicing_intros)
qed
subsection‹Fully faithful semifunctor›
subsubsection‹Definition and elementary properties›
text‹See Chapter I-3 in \cite{mac_lane_categories_2010}).›
locale is_ff_semifunctor =
is_ft_semifunctor α 𝔄 𝔅 𝔉 + is_fl_semifunctor α 𝔄 𝔅 𝔉 for α 𝔄 𝔅 𝔉
syntax "_is_ff_semifunctor" :: "V ⇒ V ⇒ V ⇒ V ⇒ bool"
(‹(_ :/ _ ↦↦⇩S⇩M⇩C⇩.⇩f⇩fı _)› [51, 51, 51] 51)
translations "𝔉 : 𝔄 ↦↦⇩S⇩M⇩C⇩.⇩f⇩f⇘α⇙ 𝔅" ⇌ "CONST is_ff_semifunctor α 𝔄 𝔅 𝔉"
text‹Rules.›
mk_ide rf is_ff_semifunctor_def
|intro is_ff_semifunctorI|
|dest is_ff_semifunctorD[dest]|
|elim is_ff_semifunctorE[elim]|
lemmas [smcf_cs_intros] = is_ff_semifunctorD
text‹Elementary properties.›
lemma (in is_ff_semifunctor) ff_smcf_is_ff_dghm:
"smcf_dghm 𝔉 : smc_dg 𝔄 ↦↦⇩D⇩G⇩.⇩f⇩f⇘α⇙ smc_dg 𝔅"
by (rule is_ff_dghmI) (auto intro: slicing_intros)
lemma (in is_ff_semifunctor) ff_smcf_is_ff_dghm'[slicing_intros]:
assumes "𝔄' = smc_dg 𝔄" and "𝔅' = smc_dg 𝔅"
shows "smcf_dghm 𝔉 : 𝔄' ↦↦⇩D⇩G⇩.⇩f⇩f⇘α⇙ 𝔅'"
unfolding assms by (rule ff_smcf_is_ff_dghm)
lemmas [slicing_intros] = is_ff_semifunctor.ff_smcf_is_ff_dghm'
subsubsection‹Opposite fully faithful semifunctor›
lemma (in is_ff_semifunctor) is_ff_semifunctor_op:
"op_smcf 𝔉 : op_smc 𝔄 ↦↦⇩S⇩M⇩C⇩.⇩f⇩f⇘α⇙ op_smc 𝔅"
by (rule is_ff_semifunctorI)
(auto simp: is_fl_semifunctor_op is_ft_semifunctor_op)
lemma (in is_ff_semifunctor) is_ff_semifunctor_op'[smc_op_intros]:
assumes "𝔄' = op_smc 𝔄" and "𝔅' = op_smc 𝔅"
shows "op_smcf 𝔉 : 𝔄' ↦↦⇩S⇩M⇩C⇩.⇩f⇩f⇘α⇙ 𝔅'"
unfolding assms by (rule is_ff_semifunctor_op)
lemmas is_ff_semifunctor_op[smc_op_intros] =
is_ff_semifunctor.is_ff_semifunctor_op'
subsubsection‹
The composition of fully faithful semifunctors is a fully faithful
semifunctor
›
lemma smcf_comp_is_ff_semifunctor[smcf_cs_intros]:
assumes "𝔊 : 𝔅 ↦↦⇩S⇩M⇩C⇩.⇩f⇩f⇘α⇙ ℭ" and "𝔉 : 𝔄 ↦↦⇩S⇩M⇩C⇩.⇩f⇩f⇘α⇙ 𝔅"
shows "𝔊 ∘⇩S⇩M⇩C⇩F 𝔉 : 𝔄 ↦↦⇩S⇩M⇩C⇩.⇩f⇩f⇘α⇙ ℭ"
using assms
by (intro is_ff_semifunctorI, elim is_ff_semifunctorE)
(auto intro: smcf_cs_intros)
subsection‹Isomorphism of semicategories›
subsubsection‹Definition and elementary properties›
text‹See Chapter I-3 in \cite{mac_lane_categories_2010}.›
locale is_iso_semifunctor = is_semifunctor α 𝔄 𝔅 𝔉 for α 𝔄 𝔅 𝔉 +
assumes iso_smcf_is_iso_dghm:
"smcf_dghm 𝔉 : smc_dg 𝔄 ↦↦⇩D⇩G⇩.⇩i⇩s⇩o⇘α⇙ smc_dg 𝔅"
syntax "_is_iso_semifunctor" :: "V ⇒ V ⇒ V ⇒ V ⇒ bool"
(‹(_ :/ _ ↦↦⇩S⇩M⇩C⇩.⇩i⇩s⇩oı _)› [51, 51, 51] 51)
translations "𝔉 : 𝔄 ↦↦⇩S⇩M⇩C⇩.⇩i⇩s⇩o⇘α⇙ 𝔅" ⇌ "CONST is_iso_semifunctor α 𝔄 𝔅 𝔉"
lemma (in is_iso_semifunctor) iso_smcf_is_iso_dghm'[slicing_intros]:
assumes "𝔄' = smc_dg 𝔄" "𝔅' = smc_dg 𝔅"
shows "smcf_dghm 𝔉 : 𝔄' ↦↦⇩D⇩G⇩.⇩i⇩s⇩o⇘α⇙ 𝔅'"
unfolding assms by (rule iso_smcf_is_iso_dghm)
lemmas [slicing_intros] = is_iso_semifunctor.iso_smcf_is_iso_dghm'
text‹Rules.›
lemma (in is_iso_semifunctor) is_iso_semifunctor_axioms'[smcf_cs_intros]:
assumes "α' = α" and "𝔄' = 𝔄" and "𝔅' = 𝔅"
shows "𝔉 : 𝔄' ↦↦⇩S⇩M⇩C⇩.⇩i⇩s⇩o⇘α'⇙ 𝔅'"
unfolding assms by (rule is_iso_semifunctor_axioms)
mk_ide rf is_iso_semifunctor_def[unfolded is_iso_semifunctor_axioms_def]
|intro is_iso_semifunctorI|
|dest is_iso_semifunctorD[dest]|
|elim is_iso_semifunctorE[elim]|
lemma is_iso_semifunctorI':
assumes "𝔉 : 𝔄 ↦↦⇩S⇩M⇩C⇘α⇙ 𝔅"
and "v11 (𝔉⦇ObjMap⦈)"
and "v11 (𝔉⦇ArrMap⦈)"
and "ℛ⇩∘ (𝔉⦇ObjMap⦈) = 𝔅⦇Obj⦈"
and "ℛ⇩∘ (𝔉⦇ArrMap⦈) = 𝔅⦇Arr⦈"
shows "𝔉 : 𝔄 ↦↦⇩S⇩M⇩C⇩.⇩i⇩s⇩o⇘α⇙ 𝔅"
using assms
by (intro is_iso_semifunctorI)
(
simp_all add:
assms(1)
is_iso_dghmI[OF is_semifunctorD(6)[OF assms(1)], unfolded slicing_simps]
)
lemma is_iso_semifunctorD':
assumes "𝔉 : 𝔄 ↦↦⇩S⇩M⇩C⇩.⇩i⇩s⇩o⇘α⇙ 𝔅"
shows "𝔉 : 𝔄 ↦↦⇩S⇩M⇩C⇘α⇙ 𝔅"
and "v11 (𝔉⦇ObjMap⦈)"
and "v11 (𝔉⦇ArrMap⦈)"
and "ℛ⇩∘ (𝔉⦇ObjMap⦈) = 𝔅⦇Obj⦈"
and "ℛ⇩∘ (𝔉⦇ArrMap⦈) = 𝔅⦇Arr⦈"
by
(
simp_all add:
is_iso_semifunctorD[OF assms(1)]
is_iso_dghmD(2-5)[
OF is_iso_semifunctorD(2)[OF assms(1)], unfolded slicing_simps
]
)
lemma is_iso_semifunctorE':
assumes "𝔉 : 𝔄 ↦↦⇩S⇩M⇩C⇩.⇩i⇩s⇩o⇘α⇙ 𝔅"
obtains "𝔉 : 𝔄 ↦↦⇩S⇩M⇩C⇘α⇙ 𝔅"
and "v11 (𝔉⦇ObjMap⦈)"
and "v11 (𝔉⦇ArrMap⦈)"
and "ℛ⇩∘ (𝔉⦇ObjMap⦈) = 𝔅⦇Obj⦈"
and "ℛ⇩∘ (𝔉⦇ArrMap⦈) = 𝔅⦇Arr⦈"
using assms by (simp_all add: is_iso_semifunctorD')
text‹Elementary properties.›
context is_iso_semifunctor
begin
interpretation dghm: is_iso_dghm α ‹smc_dg 𝔄› ‹smc_dg 𝔅› ‹smcf_dghm 𝔉›
by (rule iso_smcf_is_iso_dghm)
lemmas_with [unfolded slicing_simps]:
iso_smcf_ObjMap_vrange[smcf_cs_simps] = dghm.iso_dghm_ObjMap_vrange
and iso_smcf_ArrMap_vrange[smcf_cs_simps] = dghm.iso_dghm_ArrMap_vrange
sublocale ObjMap: v11 ‹𝔉⦇ObjMap⦈›
rewrites "𝒟⇩∘ (𝔉⦇ObjMap⦈) = 𝔄⦇Obj⦈" and "ℛ⇩∘ (𝔉⦇ObjMap⦈) = 𝔅⦇Obj⦈"
by (rule dghm.iso_dghm_ObjMap_v11[unfolded slicing_simps])
(simp_all add: smc_cs_simps smcf_cs_simps)
sublocale ArrMap: v11 ‹𝔉⦇ArrMap⦈›
rewrites "𝒟⇩∘ (𝔉⦇ArrMap⦈) = 𝔄⦇Arr⦈" and "ℛ⇩∘ (𝔉⦇ArrMap⦈) = 𝔅⦇Arr⦈"
by (rule dghm.iso_dghm_ArrMap_v11[unfolded slicing_simps])
(simp_all add: smc_cs_simps smcf_cs_simps)
lemmas_with [unfolded slicing_simps]:
iso_smcf_Obj_HomDom_if_Obj_HomCod[elim] =
dghm.iso_dghm_Obj_HomDom_if_Obj_HomCod
and iso_smcf_Arr_HomDom_if_Arr_HomCod[elim] =
dghm.iso_dghm_Arr_HomDom_if_Arr_HomCod
and iso_smcf_ObjMap_eqE[elim] = dghm.iso_dghm_ObjMap_eqE
and iso_smcf_ArrMap_eqE[elim] = dghm.iso_dghm_ArrMap_eqE
end
sublocale is_iso_semifunctor ⊆ is_ff_semifunctor
proof-
interpret dghm: is_iso_dghm α ‹smc_dg 𝔄› ‹smc_dg 𝔅› ‹smcf_dghm 𝔉›
by (rule iso_smcf_is_iso_dghm)
show "𝔉 : 𝔄 ↦↦⇩S⇩M⇩C⇩.⇩f⇩f⇘α⇙ 𝔅" by unfold_locales
qed
lemmas (in is_iso_semifunctor) iso_smcf_is_ff_semifunctor =
is_ff_semifunctor_axioms
lemmas [smcf_cs_intros] = is_iso_semifunctor.iso_smcf_is_ff_semifunctor
subsubsection‹Opposite isomorphism of semicategories›
lemma (in is_iso_semifunctor) is_iso_semifunctor_op:
"op_smcf 𝔉 : op_smc 𝔄 ↦↦⇩S⇩M⇩C⇩.⇩i⇩s⇩o⇘α⇙ op_smc 𝔅"
by
(
rule is_iso_semifunctorI,
unfold smc_op_simps slicing_simps slicing_commute[symmetric]
)
(
simp_all add:
is_semifunctor_op is_iso_dghm.is_iso_dghm_op iso_smcf_is_iso_dghm
)
lemmas is_iso_semifunctor_op[smc_op_intros] =
is_iso_semifunctor.is_iso_semifunctor_op
subsubsection‹
The composition of isomorphisms of semicategories is an isomorphism of
semicategories
›
lemma smcf_comp_is_iso_semifunctor[smcf_cs_intros]:
assumes "𝔊 : 𝔅 ↦↦⇩S⇩M⇩C⇩.⇩i⇩s⇩o⇘α⇙ ℭ" and "𝔉 : 𝔄 ↦↦⇩S⇩M⇩C⇩.⇩i⇩s⇩o⇘α⇙ 𝔅"
shows "𝔊 ∘⇩S⇩M⇩C⇩F 𝔉 : 𝔄 ↦↦⇩S⇩M⇩C⇩.⇩i⇩s⇩o⇘α⇙ ℭ"
proof(intro is_iso_semifunctorI)
interpret 𝔉: is_iso_semifunctor α 𝔄 𝔅 𝔉 using assms by auto
interpret 𝔊: is_iso_semifunctor α 𝔅 ℭ 𝔊 using assms by auto
from 𝔉.is_semifunctor_axioms 𝔊.is_semifunctor_axioms show
"𝔊 ∘⇩S⇩M⇩C⇩F 𝔉 : 𝔄 ↦↦⇩S⇩M⇩C⇘α⇙ ℭ"
by (auto intro: smcf_cs_intros)
show "smcf_dghm (𝔊 ∘⇩D⇩G⇩H⇩M 𝔉) : smc_dg 𝔄 ↦↦⇩D⇩G⇩.⇩i⇩s⇩o⇘α⇙ smc_dg ℭ"
by
(
auto
intro: dghm_cs_intros slicing_intros
simp: slicing_commute[symmetric]
)
qed
subsection‹Inverse semifunctor›
abbreviation (input) inv_smcf :: "V ⇒ V"
where "inv_smcf ≡ inv_dghm"
lemmas [smc_cs_simps] = inv_dghm_components(3,4)
text‹Slicing.›
lemma dghm_inv_smcf[slicing_commute]:
"inv_dghm (smcf_dghm 𝔉) = smcf_dghm (inv_smcf 𝔉)"
unfolding smcf_dghm_def inv_dghm_def dghm_field_simps
by (simp_all add: nat_omega_simps)
context is_iso_semifunctor
begin
interpretation dghm: is_iso_dghm α ‹smc_dg 𝔄› ‹smc_dg 𝔅› ‹smcf_dghm 𝔉›
by (rule iso_smcf_is_iso_dghm)
lemmas_with [unfolded slicing_simps slicing_commute]:
inv_smcf_ObjMap_v11 = dghm.inv_dghm_ObjMap_v11
and inv_smcf_ObjMap_vdomain = dghm.inv_dghm_ObjMap_vdomain
and inv_smcf_ObjMap_app = dghm.inv_dghm_ObjMap_app
and inv_smcf_ObjMap_vrange = dghm.inv_dghm_ObjMap_vrange
and inv_smcf_ArrMap_v11 = dghm.inv_dghm_ArrMap_v11
and inv_smcf_ArrMap_vdomain = dghm.inv_dghm_ArrMap_vdomain
and inv_smcf_ArrMap_app = dghm.inv_dghm_ArrMap_app
and inv_smcf_ArrMap_vrange = dghm.inv_dghm_ArrMap_vrange
and iso_smcf_ObjMap_inv_smcf_ObjMap_app =
dghm.iso_dghm_ObjMap_inv_dghm_ObjMap_app
and iso_smcf_ArrMap_inv_smcf_ArrMap_app =
dghm.iso_dghm_ArrMap_inv_dghm_ArrMap_app
and iso_smcf_HomDom_is_arr_conv = dghm.iso_dghm_HomDom_is_arr_conv
and iso_smcf_HomCod_is_arr_conv = dghm.iso_dghm_HomCod_is_arr_conv
end
lemmas [smcf_cs_intros] =
is_iso_semifunctor.inv_smcf_ObjMap_v11
is_iso_semifunctor.inv_smcf_ArrMap_v11
lemmas [smcf_cs_simps] =
is_iso_semifunctor.inv_smcf_ObjMap_vdomain
is_iso_semifunctor.inv_smcf_ObjMap_app
is_iso_semifunctor.inv_smcf_ObjMap_vrange
is_iso_semifunctor.inv_smcf_ArrMap_vdomain
is_iso_semifunctor.inv_smcf_ArrMap_app
is_iso_semifunctor.inv_smcf_ArrMap_vrange
is_iso_semifunctor.iso_smcf_ObjMap_inv_smcf_ObjMap_app
is_iso_semifunctor.iso_smcf_ArrMap_inv_smcf_ArrMap_app
subsection‹
An isomorphism of semicategories is an isomorphism in the category ‹SemiCAT›
›
lemma is_arr_isomorphism_is_iso_semifunctor:
assumes "𝔉 : 𝔄 ↦↦⇩S⇩M⇩C⇘α⇙ 𝔅"
and "𝔊 : 𝔅 ↦↦⇩S⇩M⇩C⇘α⇙ 𝔄"
and "𝔊 ∘⇩S⇩M⇩C⇩F 𝔉 = smcf_id 𝔄"
and "𝔉 ∘⇩S⇩M⇩C⇩F 𝔊 = smcf_id 𝔅"
shows "𝔉 : 𝔄 ↦↦⇩S⇩M⇩C⇩.⇩i⇩s⇩o⇘α⇙ 𝔅"
proof-
interpret 𝔉: is_semifunctor α 𝔄 𝔅 𝔉 by (rule assms(1))
interpret 𝔊: is_semifunctor α 𝔅 𝔄 𝔊 by (rule assms(2))
show ?thesis
proof(rule is_iso_semifunctorI)
have dg_𝔊𝔉𝔄: "smcf_dghm 𝔊 ∘⇩D⇩G⇩H⇩M smcf_dghm 𝔉 = dghm_id (smc_dg 𝔄)"
by (simp add: assms(3) smcf_dghm_smcf_id smcf_dghm_smcf_comp)
have dg_𝔉𝔊𝔅: "smcf_dghm 𝔉 ∘⇩D⇩G⇩H⇩M smcf_dghm 𝔊 = dghm_id (smc_dg 𝔅)"
by (simp add: assms(4) smcf_dghm_smcf_id smcf_dghm_smcf_comp)
from 𝔉.smcf_is_dghm 𝔊.smcf_is_dghm dg_𝔊𝔉𝔄 dg_𝔉𝔊𝔅 show
"smcf_dghm 𝔉 : smc_dg 𝔄 ↦↦⇩D⇩G⇩.⇩i⇩s⇩o⇘α⇙ smc_dg 𝔅"
by (rule is_arr_isomorphism_is_iso_dghm)
qed (simp add: 𝔉.is_semifunctor_axioms)
qed
lemma is_iso_semifunctor_is_arr_isomorphism:
assumes "𝔉 : 𝔄 ↦↦⇩S⇩M⇩C⇩.⇩i⇩s⇩o⇘α⇙ 𝔅"
shows [smcf_cs_intros]: "inv_smcf 𝔉 : 𝔅 ↦↦⇩S⇩M⇩C⇩.⇩i⇩s⇩o⇘α⇙ 𝔄"
and "inv_smcf 𝔉 ∘⇩S⇩M⇩C⇩F 𝔉 = smcf_id 𝔄"
and "𝔉 ∘⇩S⇩M⇩C⇩F inv_smcf 𝔉 = smcf_id 𝔅"
proof-
let ?𝔊 = ‹inv_smcf 𝔉›
interpret is_iso_semifunctor α 𝔄 𝔅 𝔉 by (rule assms(1))
note is_iso_dghm = is_iso_dghm_is_arr_isomorphism[OF iso_smcf_is_iso_dghm]
show 𝔊: "?𝔊 : 𝔅 ↦↦⇩S⇩M⇩C⇩.⇩i⇩s⇩o⇘α⇙ 𝔄"
proof
(
intro is_iso_semifunctorI is_semifunctorI;
(unfold slicing_commute[symmetric])?
)
show "vfsequence (inv_smcf 𝔉)" unfolding inv_dghm_def by simp
show "vcard (inv_smcf 𝔉) = 4⇩ℕ"
unfolding inv_dghm_def by (simp add: nat_omega_simps)
show inv_iso_dghm_𝔉:
"inv_dghm (smcf_dghm 𝔉) : smc_dg 𝔅 ↦↦⇩D⇩G⇩.⇩i⇩s⇩o⇘α⇙ smc_dg 𝔄"
by (rule is_iso_dghm(1))
show inv_dghm_𝔉: "inv_dghm (smcf_dghm 𝔉) : smc_dg 𝔅 ↦↦⇩D⇩G⇘α⇙ smc_dg 𝔄"
by (rule is_iso_dghmD(1)[OF inv_iso_dghm_𝔉])
fix b c g a f assume prems: "g : b ↦⇘𝔅⇙ c" "f : a ↦⇘𝔅⇙ b"
note is_arr_inv = is_dghm.dghm_ArrMap_is_arr[
OF inv_dghm_𝔉, unfolded slicing_simps slicing_commute
]
from prems is_arr_inv[OF prems(1)] is_arr_inv[OF prems(2)] show
"inv_smcf 𝔉⦇ArrMap⦈⦇g ∘⇩A⇘𝔅⇙ f⦈ =
inv_smcf 𝔉⦇ArrMap⦈⦇g⦈ ∘⇩A⇘𝔄⇙ inv_smcf 𝔉⦇ArrMap⦈⦇f⦈"
unfolding inv_dghm_components
by (intro v11.v11_vconverse_app)
(
cs_concl
cs_intro: smc_cs_intros V_cs_intros
cs_simp: V_cs_simps smc_cs_simps
)+
qed (auto simp: smc_cs_simps intro: smc_cs_intros)
show "?𝔊 ∘⇩S⇩M⇩C⇩F 𝔉 = smcf_id 𝔄"
proof(rule smcf_eqI, unfold dghm_comp_components inv_dghm_components)
from 𝔊 is_semifunctor_axioms show "inv_smcf 𝔉 ∘⇩S⇩M⇩C⇩F 𝔉 : 𝔄 ↦↦⇩S⇩M⇩C⇘α⇙ 𝔄"
by (blast intro: smc_cs_intros)
qed
(
simp_all add:
HomDom.smc_smcf_id_is_semifunctor
ObjMap.v11_vcomp_vconverse
ArrMap.v11_vcomp_vconverse
dghm_id_components
)
show "𝔉 ∘⇩S⇩M⇩C⇩F inv_smcf 𝔉 = smcf_id 𝔅"
proof(rule smcf_eqI, unfold dghm_comp_components inv_dghm_components)
from 𝔊 is_semifunctor_axioms show "𝔉 ∘⇩S⇩M⇩C⇩F inv_smcf 𝔉 : 𝔅 ↦↦⇩S⇩M⇩C⇘α⇙ 𝔅"
by (blast intro: smc_cs_intros)
qed
(
simp_all add:
HomCod.smc_smcf_id_is_semifunctor
ObjMap.v11_vcomp_vconverse'
ArrMap.v11_vcomp_vconverse'
dghm_id_components
)
qed
subsubsection‹An identity semifunctor is an isomorphism of semicategories›
lemma (in semicategory) smc_smcf_id_is_iso_semifunctor:
"smcf_id ℭ : ℭ ↦↦⇩S⇩M⇩C⇩.⇩i⇩s⇩o⇘α⇙ ℭ"
by (rule is_iso_semifunctorI, unfold slicing_simps slicing_commute[symmetric])
(
simp_all add:
smc_smcf_id_is_semifunctor digraph.dg_dghm_id_is_iso_dghm smc_digraph
)
lemma (in semicategory) smc_smcf_id_is_iso_semifunctor'[smcf_cs_intros]:
assumes "𝔄' = ℭ" and "𝔅' = ℭ"
shows "smcf_id ℭ : 𝔄' ↦↦⇩S⇩M⇩C⇩.⇩i⇩s⇩o⇘α⇙ 𝔅'"
unfolding assms by (rule smc_smcf_id_is_iso_semifunctor)
lemmas [smcf_cs_intros] = semicategory.smc_smcf_id_is_iso_semifunctor'
subsection‹Isomorphic semicategories›
subsubsection‹Definition and elementary properties›
text‹See Chapter I-3 in \cite{mac_lane_categories_2010}).›
locale iso_semicategory = L: semicategory α 𝔄 + R: semicategory α 𝔅
for α 𝔄 𝔅 +
assumes iso_smc_is_iso_semifunctor: "∃𝔉. 𝔉 : 𝔄 ↦↦⇩S⇩M⇩C⇩.⇩i⇩s⇩o⇘α⇙ 𝔅"
notation iso_semicategory (infixl "≈⇩S⇩M⇩Cı" 50)
text‹Rules.›
lemma iso_semicategoryI:
assumes "𝔉 : 𝔄 ↦↦⇩S⇩M⇩C⇩.⇩i⇩s⇩o⇘α⇙ 𝔅"
shows "𝔄 ≈⇩S⇩M⇩C⇘α⇙ 𝔅"
using assms
unfolding iso_semicategory_def iso_semicategory_axioms_def
by blast
lemma iso_semicategoryD[dest]:
assumes "𝔄 ≈⇩S⇩M⇩C⇘α⇙ 𝔅"
shows "∃𝔉. 𝔉 : 𝔄 ↦↦⇩S⇩M⇩C⇩.⇩i⇩s⇩o⇘α⇙ 𝔅"
using assms
unfolding iso_semicategory_def iso_semicategory_axioms_def
by simp_all
lemma iso_semicategoryE[elim]:
assumes "𝔄 ≈⇩S⇩M⇩C⇘α⇙ 𝔅"
obtains 𝔉 where "𝔉 : 𝔄 ↦↦⇩S⇩M⇩C⇩.⇩i⇩s⇩o⇘α⇙ 𝔅"
using assms by auto
text‹Elementary properties.›
lemma (in iso_semicategory) iso_smc_iso_digraph: "smc_dg 𝔄 ≈⇩D⇩G⇘α⇙ smc_dg 𝔅"
using iso_smc_is_iso_semifunctor
by (auto intro: slicing_intros iso_digraphI)
subsubsection‹A semicategory isomorphism is an equivalence relation›
lemma iso_semicategory_refl:
assumes "semicategory α 𝔄"
shows "𝔄 ≈⇩S⇩M⇩C⇘α⇙ 𝔄"
proof(rule iso_semicategoryI[of _ _ _ ‹smcf_id 𝔄›])
interpret semicategory α 𝔄 by (rule assms)
show "smcf_id 𝔄 : 𝔄 ↦↦⇩S⇩M⇩C⇩.⇩i⇩s⇩o⇘α⇙ 𝔄"
by (simp add: smc_smcf_id_is_iso_semifunctor)
qed
lemma iso_semicategory_sym[sym]:
assumes "𝔄 ≈⇩S⇩M⇩C⇘α⇙ 𝔅"
shows "𝔅 ≈⇩S⇩M⇩C⇘α⇙ 𝔄"
proof-
interpret iso_semicategory α 𝔄 𝔅 by (rule assms)
from iso_smc_is_iso_semifunctor obtain 𝔉 where "𝔉 : 𝔄 ↦↦⇩S⇩M⇩C⇩.⇩i⇩s⇩o⇘α⇙ 𝔅"
by clarsimp
then have "inv_smcf 𝔉 : 𝔅 ↦↦⇩S⇩M⇩C⇩.⇩i⇩s⇩o⇘α⇙ 𝔄"
by (simp add: is_iso_semifunctor_is_arr_isomorphism(1))
then show ?thesis by (auto intro: iso_semicategoryI)
qed
lemma iso_semicategory_trans[trans]:
assumes "𝔄 ≈⇩S⇩M⇩C⇘α⇙ 𝔅" and "𝔅 ≈⇩S⇩M⇩C⇘α⇙ ℭ"
shows "𝔄 ≈⇩S⇩M⇩C⇘α⇙ ℭ"
proof-
interpret L: iso_semicategory α 𝔄 𝔅 by (rule assms(1))
interpret R: iso_semicategory α 𝔅 ℭ by (rule assms(2))
from L.iso_smc_is_iso_semifunctor R.iso_smc_is_iso_semifunctor show ?thesis
by (auto intro: iso_semicategoryI smcf_cs_intros)
qed
text‹\newpage›
end
Theory CZH_SMC_Small_Semifunctor
section‹Smallness for semifunctors›
theory CZH_SMC_Small_Semifunctor
imports
CZH_DG_Small_DGHM
CZH_SMC_Semifunctor
CZH_SMC_Small_Semicategory
begin
subsection‹Semifunctor with tiny maps›
subsubsection‹Definition and elementary properties›
locale is_tm_semifunctor = is_semifunctor α 𝔄 𝔅 𝔉 for α 𝔄 𝔅 𝔉 +
assumes tm_smcf_is_tm_dghm[slicing_intros]:
"smcf_dghm 𝔉 : smc_dg 𝔄 ↦↦⇩D⇩G⇩.⇩t⇩m⇘α⇙ smc_dg 𝔅"
syntax "_is_tm_semifunctor" :: "V ⇒ V ⇒ V ⇒ V ⇒ bool"
(‹(_ :/ _ ↦↦⇩S⇩M⇩C⇩.⇩t⇩mı _)› [51, 51, 51] 51)
translations "𝔉 : 𝔄 ↦↦⇩S⇩M⇩C⇩.⇩t⇩m⇘α⇙ 𝔅" ⇌ "CONST is_tm_semifunctor α 𝔄 𝔅 𝔉"
abbreviation (input) is_cn_tm_semifunctor :: "V ⇒ V ⇒ V ⇒ V ⇒ bool"
where "is_cn_tm_semifunctor α 𝔄 𝔅 𝔉 ≡ 𝔉 : op_dg 𝔄 ↦↦⇩S⇩M⇩C⇩.⇩t⇩m⇘α⇙ 𝔅"
syntax "_is_cn_tm_semifunctor" :: "V ⇒ V ⇒ V ⇒ V ⇒ bool"
(‹(_ :/ _ ⇩S⇩M⇩C⇩.⇩t⇩m↦↦ı _)› [51, 51, 51] 51)
translations "𝔉 : 𝔄 ⇩S⇩M⇩C⇩.⇩t⇩m↦↦⇘α⇙ 𝔅" ⇀ "CONST is_cn_tm_semifunctor α 𝔄 𝔅 𝔉"
abbreviation all_tm_smcfs :: "V ⇒ V"
where "all_tm_smcfs α ≡ set {𝔉. ∃𝔄 𝔅. 𝔉 : 𝔄 ↦↦⇩S⇩M⇩C⇩.⇩t⇩m⇘α⇙ 𝔅}"
abbreviation small_tm_smcfs :: "V ⇒ V ⇒ V ⇒ V"
where "small_tm_smcfs α 𝔄 𝔅 ≡ set {𝔉. 𝔉 : 𝔄 ↦↦⇩S⇩M⇩C⇩.⇩t⇩m⇘α⇙ 𝔅}"
lemma (in is_tm_semifunctor) tm_smcf_is_tm_dghm':
assumes "α' = α"
and "𝔄' = smc_dg 𝔄"
and "𝔅' = smc_dg 𝔅"
shows "smcf_dghm 𝔉 : 𝔄' ↦↦⇩D⇩G⇩.⇩t⇩m⇘α'⇙ 𝔅'"
unfolding assms by (rule tm_smcf_is_tm_dghm)
lemmas [slicing_intros] = is_tm_semifunctor.tm_smcf_is_tm_dghm'
text‹Rules.›
lemma (in is_tm_semifunctor) is_tm_semifunctor_axioms'[smc_small_cs_intros]:
assumes "α' = α" and "𝔄' = 𝔄" and "𝔅' = 𝔅"
shows "𝔉 : 𝔄' ↦↦⇩S⇩M⇩C⇩.⇩t⇩m⇘α'⇙ 𝔅'"
unfolding assms by (rule is_tm_semifunctor_axioms)
mk_ide rf is_tm_semifunctor_def[unfolded is_tm_semifunctor_axioms_def]
|intro is_tm_semifunctorI|
|dest is_tm_semifunctorD[dest]|
|elim is_tm_semifunctorE[elim]|
lemmas [smc_small_cs_intros] = is_tm_semifunctorD(1)
text‹Slicing.›
context is_tm_semifunctor
begin
interpretation dghm: is_tm_dghm α ‹smc_dg 𝔄› ‹smc_dg 𝔅› ‹smcf_dghm 𝔉›
by (rule tm_smcf_is_tm_dghm)
lemmas_with [unfolded slicing_simps]:
tm_smcf_ObjMap_in_Vset[smc_small_cs_intros] = dghm.tm_dghm_ObjMap_in_Vset
and tm_smcf_ArrMap_in_Vset[smc_small_cs_intros] = dghm.tm_dghm_ArrMap_in_Vset
end
text‹Elementary properties.›
sublocale is_tm_semifunctor ⊆ HomDom: tiny_semicategory α 𝔄
proof(rule tiny_semicategoryI')
show "𝔄⦇Obj⦈ ∈⇩∘ Vset α"
by (rule vdomain_in_VsetI[OF tm_smcf_ObjMap_in_Vset, unfolded smc_cs_simps])
show "𝔄⦇Arr⦈ ∈⇩∘ Vset α"
by (rule vdomain_in_VsetI[OF tm_smcf_ArrMap_in_Vset, unfolded smc_cs_simps])
qed (simp add: smc_cs_intros)
text‹Further rules.›
lemma is_tm_semifunctorI':
assumes [simp]: "𝔉 : 𝔄 ↦↦⇩S⇩M⇩C⇘α⇙ 𝔅"
and [simp]: "𝔉⦇ObjMap⦈ ∈⇩∘ Vset α"
and [simp]: "𝔉⦇ArrMap⦈ ∈⇩∘ Vset α"
and [simp]: "semicategory α 𝔅"
shows "𝔉 : 𝔄 ↦↦⇩S⇩M⇩C⇩.⇩t⇩m⇘α⇙ 𝔅"
proof(intro is_tm_semifunctorI)
interpret is_semifunctor α 𝔄 𝔅 𝔉 by (rule assms(1))
show "smcf_dghm 𝔉 : smc_dg 𝔄 ↦↦⇩D⇩G⇩.⇩t⇩m⇘α⇙ smc_dg 𝔅"
by (intro is_tm_dghmI', unfold slicing_simps) (auto simp: slicing_intros)
qed simp_all
lemma is_tm_semifunctorD':
assumes "𝔉 : 𝔄 ↦↦⇩S⇩M⇩C⇩.⇩t⇩m⇘α⇙ 𝔅"
shows "semicategory α 𝔅"
and "𝔉 : 𝔄 ↦↦⇩S⇩M⇩C⇘α⇙ 𝔅"
and "𝔉⦇ObjMap⦈ ∈⇩∘ Vset α"
and "𝔉⦇ArrMap⦈ ∈⇩∘ Vset α"
proof-
interpret is_tm_semifunctor α 𝔄 𝔅 𝔉 by (rule assms(1))
show "semicategory α 𝔅"
and "𝔉 : 𝔄 ↦↦⇩S⇩M⇩C⇘α⇙ 𝔅"
and "𝔉⦇ObjMap⦈ ∈⇩∘ Vset α"
and "𝔉⦇ArrMap⦈ ∈⇩∘ Vset α"
by (auto intro: smc_cs_intros smc_small_cs_intros)
qed
lemmas [smc_small_cs_intros] = is_tm_semifunctorD'(1)
lemma is_tm_semifunctorE':
assumes "𝔉 : 𝔄 ↦↦⇩S⇩M⇩C⇩.⇩t⇩m⇘α⇙ 𝔅"
obtains "semicategory α 𝔅"
and "𝔉 : 𝔄 ↦↦⇩S⇩M⇩C⇘α⇙ 𝔅"
and "𝔉⦇ObjMap⦈ ∈⇩∘ Vset α"
and "𝔉⦇ArrMap⦈ ∈⇩∘ Vset α"
using is_tm_semifunctorD'[OF assms] by simp
text‹Size.›
lemma small_all_tm_smcfs[simp]: "small {𝔉. ∃𝔄 𝔅. 𝔉 : 𝔄 ↦↦⇩S⇩M⇩C⇩.⇩t⇩m⇘α⇙ 𝔅}"
proof(rule down)
show
"{𝔉. ∃𝔄 𝔅. 𝔉 : 𝔄 ↦↦⇩S⇩M⇩C⇩.⇩t⇩m⇘α⇙ 𝔅} ⊆
elts (set {𝔉. ∃𝔄 𝔅. 𝔉 : 𝔄 ↦↦⇩S⇩M⇩C⇘α⇙ 𝔅})"
proof
(
simp only: elts_of_set small_all_smcfs if_True,
rule subsetI,
unfold mem_Collect_eq
)
fix 𝔉 assume "∃𝔄 𝔅. 𝔉 : 𝔄 ↦↦⇩S⇩M⇩C⇩.⇩t⇩m⇘α⇙ 𝔅"
then obtain 𝔄 𝔅 where "𝔉 : 𝔄 ↦↦⇩S⇩M⇩C⇩.⇩t⇩m⇘α⇙ 𝔅" by clarsimp
then interpret is_tm_semifunctor α 𝔄 𝔅 𝔉 by simp
show "∃𝔄 𝔅. 𝔉 : 𝔄 ↦↦⇩S⇩M⇩C⇘α⇙ 𝔅" by (auto intro: is_semifunctor_axioms)
qed
qed
subsubsection‹Opposite semifunctor with tiny maps›
lemma (in is_tm_semifunctor) is_tm_semifunctor_op:
"op_smcf 𝔉 : op_smc 𝔄 ↦↦⇩S⇩M⇩C⇩.⇩t⇩m⇘α⇙ op_smc 𝔅"
by (intro is_tm_semifunctorI', unfold smc_op_simps)
(cs_concl cs_intro: smc_cs_intros smc_op_intros smc_small_cs_intros)
lemma (in is_tm_semifunctor) is_tm_semifunctor_op'[smc_op_intros]:
assumes "𝔄' = op_smc 𝔄" and "𝔅' = op_smc 𝔅" and "α' = α"
shows "op_smcf 𝔉 : 𝔄' ↦↦⇩S⇩M⇩C⇩.⇩t⇩m⇘α'⇙ 𝔅'"
unfolding assms by (rule is_tm_semifunctor_op)
lemmas is_tm_semifunctor_op[smc_op_intros] = is_tm_semifunctor.is_tm_semifunctor_op'
subsubsection‹Composition of semifunctors with tiny maps›
lemma smcf_comp_is_tm_semifunctor[smc_small_cs_intros]:
assumes "𝔊 : 𝔅 ↦↦⇩S⇩M⇩C⇩.⇩t⇩m⇘α⇙ ℭ" and "𝔉 : 𝔄 ↦↦⇩S⇩M⇩C⇩.⇩t⇩m⇘α⇙ 𝔅"
shows "𝔊 ∘⇩S⇩M⇩C⇩F 𝔉 : 𝔄 ↦↦⇩S⇩M⇩C⇩.⇩t⇩m⇘α⇙ ℭ"
proof(rule is_tm_semifunctorI)
interpret 𝔉: is_tm_semifunctor α 𝔄 𝔅 𝔉 by (rule assms(2))
interpret 𝔊: is_tm_semifunctor α 𝔅 ℭ 𝔊 by (rule assms(1))
show "smcf_dghm (𝔊 ∘⇩S⇩M⇩C⇩F 𝔉) : smc_dg 𝔄 ↦↦⇩D⇩G⇩.⇩t⇩m⇘α⇙ smc_dg ℭ"
unfolding slicing_commute[symmetric]
using 𝔉.tm_smcf_is_tm_dghm 𝔊.tm_smcf_is_tm_dghm
by (auto simp: dg_small_cs_intros)
show "𝔊 ∘⇩S⇩M⇩C⇩F 𝔉 : 𝔄 ↦↦⇩S⇩M⇩C⇘α⇙ ℭ" by (auto intro: smc_cs_intros)
qed
subsubsection‹Finite semicategories and semifunctors with tiny maps›
lemma (in is_semifunctor) smcf_is_tm_semifunctor_if_HomDom_finite_semicategory:
assumes "finite_semicategory α 𝔄"
shows "𝔉 : 𝔄 ↦↦⇩S⇩M⇩C⇩.⇩t⇩m⇘α⇙ 𝔅"
proof(intro is_tm_semifunctorI)
interpret 𝔄: finite_semicategory α 𝔄 by (rule assms(1))
show "smcf_dghm 𝔉 : smc_dg 𝔄 ↦↦⇩D⇩G⇩.⇩t⇩m⇘α⇙ smc_dg 𝔅"
by
(
rule is_dghm.dghm_is_tm_dghm_if_HomDom_finite_digraph[
OF smcf_is_dghm 𝔄.fin_smc_finite_digraph
]
)
qed (auto intro: smc_cs_intros)
subsubsection‹Constant semifunctor with tiny maps›
lemma smcf_const_is_tm_semifunctor:
assumes "tiny_semicategory α ℭ"
and "semicategory α 𝔇"
and "f : a ↦⇘𝔇⇙ a"
and "f ∘⇩A⇘𝔇⇙ f = f"
shows "smcf_const ℭ 𝔇 a f : ℭ ↦↦⇩S⇩M⇩C⇩.⇩t⇩m⇘α⇙ 𝔇"
proof(intro is_tm_semifunctorI)
interpret ℭ: tiny_semicategory α ℭ by (rule assms(1))
interpret 𝔇: semicategory α 𝔇 by (rule assms(2))
show "smcf_dghm (smcf_const ℭ 𝔇 a f) : smc_dg ℭ ↦↦⇩D⇩G⇩.⇩t⇩m⇘α⇙ smc_dg 𝔇"
unfolding slicing_commute[symmetric]
by (rule dghm_const_is_tm_dghm)
(auto simp: slicing_simps ℭ.tiny_smc_tiny_digraph assms(3) 𝔇.smc_digraph)
from assms show "smcf_const ℭ 𝔇 a f : ℭ ↦↦⇩S⇩M⇩C⇘α⇙ 𝔇"
by (cs_concl cs_simp: smc_cs_simps cs_intro: smc_cs_intros)
qed
lemma smcf_const_is_tm_semifunctor':
assumes "tiny_semicategory α ℭ"
and "semicategory α 𝔇"
and "f : a ↦⇘𝔇⇙ a"
and "f ∘⇩A⇘𝔇⇙ f = f"
and "ℭ' = ℭ"
and "𝔇' = 𝔇"
shows "smcf_const ℭ 𝔇 a f : ℭ' ↦↦⇩S⇩M⇩C⇩.⇩t⇩m⇘α⇙ 𝔇'"
using assms(1-4) unfolding assms(5,6) by (rule smcf_const_is_tm_semifunctor)
lemmas [smc_small_cs_intros] = smcf_const_is_tm_semifunctor'
subsection‹Tiny semifunctor›
subsubsection‹Definition and elementary properties›
locale is_tiny_semifunctor = is_semifunctor α 𝔄 𝔅 𝔉 for α 𝔄 𝔅 𝔉 +
assumes tiny_smcf_is_tiny_dghm[slicing_intros]:
"smcf_dghm 𝔉 : smc_dg 𝔄 ↦↦⇩D⇩G⇩.⇩t⇩i⇩n⇩y⇘α⇙ smc_dg 𝔅"
syntax "_is_tiny_semifunctor" :: "V ⇒ V ⇒ V ⇒ V ⇒ bool"
(‹(_ :/ _ ↦↦⇩S⇩M⇩C⇩.⇩t⇩i⇩n⇩yı _)› [51, 51, 51] 51)
translations "𝔉 : 𝔄 ↦↦⇩S⇩M⇩C⇩.⇩t⇩i⇩n⇩y⇘α⇙ 𝔅" ⇌ "CONST is_tiny_semifunctor α 𝔄 𝔅 𝔉"
abbreviation (input) is_cn_tiny_smcf :: "V ⇒ V ⇒ V ⇒ V ⇒ bool"
where "is_cn_tiny_smcf α 𝔄 𝔅 𝔉 ≡ 𝔉 : op_smc 𝔄 ↦↦⇩S⇩M⇩C⇩.⇩t⇩i⇩n⇩y⇘α⇙ 𝔅"
syntax "_is_cn_tiny_smcf" :: "V ⇒ V ⇒ V ⇒ V ⇒ bool"
(‹(_ :/ _ ⇩S⇩M⇩C⇩.⇩t⇩i⇩n⇩y↦↦ı _)› [51, 51, 51] 51)
translations "𝔉 : 𝔄 ⇩S⇩M⇩C⇩.⇩t⇩i⇩n⇩y↦↦⇘α⇙ 𝔅" ⇀ "CONST is_cn_tiny_smcf α 𝔄 𝔅 𝔉"
abbreviation all_tiny_smcfs :: "V ⇒ V"
where "all_tiny_smcfs α ≡ set {𝔉. ∃𝔄 𝔅. 𝔉 : 𝔄 ↦↦⇩S⇩M⇩C⇩.⇩t⇩i⇩n⇩y⇘α⇙ 𝔅}"
abbreviation tiny_smcfs :: "V ⇒ V ⇒ V ⇒ V"
where "tiny_smcfs α 𝔄 𝔅 ≡ set {𝔉. 𝔉 : 𝔄 ↦↦⇩S⇩M⇩C⇩.⇩t⇩i⇩n⇩y⇘α⇙ 𝔅}"
lemmas [slicing_intros] = is_tiny_semifunctor.tiny_smcf_is_tiny_dghm
text‹Rules.›
lemma (in is_tiny_semifunctor) is_tiny_semifunctor_axioms'[smc_small_cs_intros]:
assumes "α' = α" and "𝔄' = 𝔄" and "𝔅' = 𝔅"
shows "𝔉 : 𝔄' ↦↦⇩S⇩M⇩C⇩.⇩t⇩i⇩n⇩y⇘α'⇙ 𝔅'"
unfolding assms by (rule is_tiny_semifunctor_axioms)
mk_ide rf is_tiny_semifunctor_def[unfolded is_tiny_semifunctor_axioms_def]
|intro is_tiny_semifunctorI|
|dest is_tiny_semifunctorD[dest]|
|elim is_tiny_semifunctorE[elim]|
lemmas [smc_small_cs_intros] = is_tiny_semifunctorD(1)
text‹Elementary properties.›
sublocale is_tiny_semifunctor ⊆ HomDom: tiny_semicategory α 𝔄
proof(intro tiny_semicategoryI')
interpret dghm: is_tiny_dghm α ‹smc_dg 𝔄› ‹smc_dg 𝔅› ‹smcf_dghm 𝔉›
by (rule tiny_smcf_is_tiny_dghm)
show "𝔄⦇Obj⦈ ∈⇩∘ Vset α"
by (rule dghm.HomDom.tiny_dg_Obj_in_Vset[unfolded slicing_simps])
show "𝔄⦇Arr⦈ ∈⇩∘ Vset α"
by (rule dghm.HomDom.tiny_dg_Arr_in_Vset[unfolded slicing_simps])
qed (auto simp: smc_cs_intros)
sublocale is_tiny_semifunctor ⊆ HomCod: tiny_semicategory α 𝔅
proof(intro tiny_semicategoryI')
interpret dghm: is_tiny_dghm α ‹smc_dg 𝔄› ‹smc_dg 𝔅› ‹smcf_dghm 𝔉›
by (rule tiny_smcf_is_tiny_dghm)
show "𝔅⦇Obj⦈ ∈⇩∘ Vset α"
by (rule dghm.HomCod.tiny_dg_Obj_in_Vset[unfolded slicing_simps])
show "𝔅⦇Arr⦈ ∈⇩∘ Vset α"
by (rule dghm.HomCod.tiny_dg_Arr_in_Vset[unfolded slicing_simps])
qed (auto simp: smc_cs_intros)
sublocale is_tiny_semifunctor ⊆ is_tm_semifunctor
proof(intro is_tm_semifunctorI')
interpret dghm: is_tiny_dghm α ‹smc_dg 𝔄› ‹smc_dg 𝔅› ‹smcf_dghm 𝔉›
by (rule tiny_smcf_is_tiny_dghm)
note Vset[unfolded slicing_simps] =
dghm.tiny_dghm_ObjMap_in_Vset
dghm.tiny_dghm_ArrMap_in_Vset
show "𝔉⦇ObjMap⦈ ∈⇩∘ Vset α" "𝔉⦇ArrMap⦈ ∈⇩∘ Vset α" by (intro Vset)+
qed (auto simp: smc_cs_intros)
text‹Further rules.›
lemma is_tiny_semifunctorI':
assumes "𝔉 : 𝔄 ↦↦⇩S⇩M⇩C⇘α⇙ 𝔅"
and "tiny_semicategory α 𝔄"
and "tiny_semicategory α 𝔅"
shows "𝔉 : 𝔄 ↦↦⇩S⇩M⇩C⇩.⇩t⇩i⇩n⇩y⇘α⇙ 𝔅"
using assms
by
(
auto simp:
smc_cs_simps
smc_cs_intros
is_semifunctor.smcf_is_dghm
is_tiny_dghm.intro
is_tiny_semifunctorI
tiny_semicategory.tiny_smc_tiny_digraph
)
lemma is_tiny_semifunctorD':
assumes "𝔉 : 𝔄 ↦↦⇩S⇩M⇩C⇩.⇩t⇩i⇩n⇩y⇘α⇙ 𝔅"
shows "𝔉 : 𝔄 ↦↦⇩S⇩M⇩C⇘α⇙ 𝔅"
and "tiny_semicategory α 𝔄"
and "tiny_semicategory α 𝔅"
proof-
interpret is_tiny_semifunctor α 𝔄 𝔅 𝔉 by (rule assms(1))
show "𝔉 : 𝔄 ↦↦⇩S⇩M⇩C⇘α⇙ 𝔅"
and "tiny_semicategory α 𝔄"
and "tiny_semicategory α 𝔅"
by (auto intro: smc_small_cs_intros)
qed
lemmas [smc_small_cs_intros] = is_tiny_semifunctorD'(2,3)
lemma is_tiny_semifunctorE':
assumes "𝔉 : 𝔄 ↦↦⇩S⇩M⇩C⇩.⇩t⇩i⇩n⇩y⇘α⇙ 𝔅"
obtains "𝔉 : 𝔄 ↦↦⇩S⇩M⇩C⇘α⇙ 𝔅"
and "tiny_semicategory α 𝔄"
and "tiny_semicategory α 𝔅"
using is_tiny_semifunctorD'[OF assms] by auto
lemma is_tiny_semifunctor_iff:
"𝔉 : 𝔄 ↦↦⇩S⇩M⇩C⇩.⇩t⇩i⇩n⇩y⇘α⇙ 𝔅 ⟷
(𝔉 : 𝔄 ↦↦⇩S⇩M⇩C⇘α⇙ 𝔅 ∧ tiny_semicategory α 𝔄 ∧ tiny_semicategory α 𝔅)"
by (auto intro: is_tiny_semifunctorI' dest: is_tiny_semifunctorD'(2,3))
text‹Size.›
lemma (in is_tiny_semifunctor) tiny_smcf_in_Vset: "𝔉 ∈⇩∘ Vset α"
proof-
note [smc_cs_intros] =
tm_smcf_ObjMap_in_Vset
tm_smcf_ArrMap_in_Vset
HomDom.tiny_smc_in_Vset
HomCod.tiny_smc_in_Vset
show ?thesis
by (subst smcf_def)
(cs_concl cs_simp: smc_cs_simps cs_intro: smc_cs_intros V_cs_intros)
qed
lemma small_all_tiny_smcfs[simp]: "small {𝔉. ∃𝔄 𝔅. 𝔉 : 𝔄 ↦↦⇩S⇩M⇩C⇩.⇩t⇩i⇩n⇩y⇘α⇙ 𝔅}"
proof(rule down)
show
"{𝔉. ∃𝔄 𝔅. 𝔉 : 𝔄 ↦↦⇩S⇩M⇩C⇩.⇩t⇩i⇩n⇩y⇘α⇙ 𝔅} ⊆
elts (set {𝔉. ∃𝔄 𝔅. 𝔉 : 𝔄 ↦↦⇩S⇩M⇩C⇘α⇙ 𝔅})"
proof
(
simp only: elts_of_set small_all_smcfs if_True,
rule subsetI,
unfold mem_Collect_eq
)
fix 𝔉 assume "∃𝔄 𝔅. 𝔉 : 𝔄 ↦↦⇩S⇩M⇩C⇩.⇩t⇩i⇩n⇩y⇘α⇙ 𝔅"
then obtain 𝔄 𝔅 where "𝔉 : 𝔄 ↦↦⇩S⇩M⇩C⇩.⇩t⇩i⇩n⇩y⇘α⇙ 𝔅" by clarsimp
then interpret is_tiny_semifunctor α 𝔄 𝔅 𝔉 by simp
show "∃𝔄 𝔅. 𝔉 : 𝔄 ↦↦⇩S⇩M⇩C⇘α⇙ 𝔅" using is_semifunctor_axioms by auto
qed
qed
lemma tiny_smcfs_vsubset_Vset[simp]:
"set {𝔉. ∃𝔄 𝔅. 𝔉 : 𝔄 ↦↦⇩S⇩M⇩C⇩.⇩t⇩i⇩n⇩y⇘α⇙ 𝔅} ⊆⇩∘ Vset α"
proof(rule vsubsetI)
fix 𝔉 assume "𝔉 ∈⇩∘ all_tiny_smcfs α"
then obtain 𝔄 𝔅 where 𝔉: "𝔉 : 𝔄 ↦↦⇩S⇩M⇩C⇩.⇩t⇩i⇩n⇩y⇘α⇙ 𝔅" by clarsimp
then show "𝔉 ∈⇩∘ Vset α" by (auto simp: is_tiny_semifunctor.tiny_smcf_in_Vset)
qed
lemma (in is_semifunctor) smcf_is_tiny_semifunctor_if_ge_Limit:
assumes "𝒵 β" and "α ∈⇩∘ β"
shows "𝔉 : 𝔄 ↦↦⇩S⇩M⇩C⇩.⇩t⇩i⇩n⇩y⇘β⇙ 𝔅"
proof(intro is_tiny_semifunctorI)
show "smcf_dghm 𝔉 : smc_dg 𝔄 ↦↦⇩D⇩G⇩.⇩t⇩i⇩n⇩y⇘β⇙ smc_dg 𝔅"
by
(
rule is_dghm.dghm_is_tiny_dghm_if_ge_Limit,
rule smcf_is_dghm;
intro assms
)
qed (simp add: smcf_is_semifunctor_if_ge_Limit assms)
subsubsection‹Opposite tiny semifunctor›
lemma (in is_tiny_semifunctor) is_tiny_semifunctor_op:
"op_smcf 𝔉 : op_smc 𝔄 ↦↦⇩S⇩M⇩C⇩.⇩t⇩i⇩n⇩y⇘α⇙ op_smc 𝔅"
by (intro is_tiny_semifunctorI')
(cs_concl cs_intro: smc_small_cs_intros smc_op_intros)+
lemma (in is_tiny_semifunctor) is_tiny_semifunctor_op'[smc_op_intros]:
assumes "𝔄' = op_smc 𝔄" and "𝔅' = op_smc 𝔅" and "α' = α"
shows "op_smcf 𝔉 : 𝔄' ↦↦⇩S⇩M⇩C⇩.⇩t⇩i⇩n⇩y⇘α'⇙ 𝔅'"
unfolding assms by (rule is_tiny_semifunctor_op)
lemmas is_tiny_semifunctor_op[smc_op_intros] =
is_tiny_semifunctor.is_tiny_semifunctor_op'
subsubsection‹Composition of tiny semifunctors›
lemma smcf_comp_is_tiny_semifunctor[smc_small_cs_intros]:
assumes "𝔊 : 𝔅 ↦↦⇩S⇩M⇩C⇩.⇩t⇩i⇩n⇩y⇘α⇙ ℭ" and "𝔉 : 𝔄 ↦↦⇩S⇩M⇩C⇩.⇩t⇩i⇩n⇩y⇘α⇙ 𝔅"
shows "𝔊 ∘⇩S⇩M⇩C⇩F 𝔉 : 𝔄 ↦↦⇩S⇩M⇩C⇩.⇩t⇩i⇩n⇩y⇘α⇙ ℭ"
proof-
interpret 𝔉: is_tiny_semifunctor α 𝔄 𝔅 𝔉 by (rule assms(2))
interpret 𝔊: is_tiny_semifunctor α 𝔅 ℭ 𝔊 by (rule assms(1))
show ?thesis
by (rule is_tiny_semifunctorI')
(cs_concl cs_intro: smc_cs_intros smc_small_cs_intros)
qed
subsubsection‹Tiny constant semifunctor›
lemma smcf_const_is_tiny_semifunctor:
assumes "tiny_semicategory α ℭ"
and "tiny_semicategory α 𝔇"
and "f : a ↦⇘𝔇⇙ a"
and "f ∘⇩A⇘𝔇⇙ f = f"
shows "smcf_const ℭ 𝔇 a f : ℭ ↦↦⇩S⇩M⇩C⇩.⇩t⇩i⇩n⇩y⇘α⇙ 𝔇"
proof(intro is_tiny_semifunctorI')
from assms show "smcf_const ℭ 𝔇 a f : ℭ ↦↦⇩S⇩M⇩C⇘α⇙ 𝔇"
by (cs_concl cs_simp: smc_cs_simps cs_intro: smc_small_cs_intros)
qed (auto simp: assms(1,2))
lemma smcf_const_is_tiny_semifunctor'[smc_small_cs_intros]:
assumes "tiny_semicategory α ℭ"
and "tiny_semicategory α 𝔇"
and "f : a ↦⇘𝔇⇙ a"
and "f ∘⇩A⇘𝔇⇙ f = f"
and "ℭ' = ℭ"
and "𝔇' = 𝔇"
shows "smcf_const ℭ 𝔇 a f : ℭ' ↦↦⇩S⇩M⇩C⇩.⇩t⇩i⇩n⇩y⇘α⇙ 𝔇'"
using assms(1-4) unfolding assms(5,6) by (rule smcf_const_is_tiny_semifunctor)
text‹\newpage›
end
Theory CZH_SMC_NTSMCF
section‹Natural transformation of a semifunctor›
theory CZH_SMC_NTSMCF
imports
CZH_SMC_Semifunctor
CZH_DG_TDGHM
begin
subsection‹Background›
named_theorems ntsmcf_cs_simps
named_theorems ntsmcf_cs_intros
lemmas [smc_cs_simps] = dg_shared_cs_simps
lemmas [smc_cs_intros] = dg_shared_cs_intros
subsubsection‹Slicing›
definition ntsmcf_tdghm :: "V ⇒ V"
where "ntsmcf_tdghm 𝔑 =
[
𝔑⦇NTMap⦈,
smcf_dghm (𝔑⦇NTDom⦈),
smcf_dghm (𝔑⦇NTCod⦈),
smc_dg (𝔑⦇NTDGDom⦈),
smc_dg (𝔑⦇NTDGCod⦈)
]⇩∘"
text‹Components.›
lemma ntsmcf_tdghm_components:
shows [slicing_simps]: "ntsmcf_tdghm 𝔑⦇NTMap⦈ = 𝔑⦇NTMap⦈"
and [slicing_commute]: "ntsmcf_tdghm 𝔑⦇NTDom⦈ = smcf_dghm (𝔑⦇NTDom⦈)"
and [slicing_commute]: "ntsmcf_tdghm 𝔑⦇NTCod⦈ = smcf_dghm (𝔑⦇NTCod⦈)"
and [slicing_commute]: "ntsmcf_tdghm 𝔑⦇NTDGDom⦈ = smc_dg (𝔑⦇NTDGDom⦈)"
and [slicing_commute]: "ntsmcf_tdghm 𝔑⦇NTDGCod⦈ = smc_dg (𝔑⦇NTDGCod⦈)"
unfolding ntsmcf_tdghm_def nt_field_simps by (auto simp: nat_omega_simps)
subsection‹Definition and elementary properties›
text‹
A natural transformation of semifunctors, as presented in this work,
is a generalization of the concept of a natural transformation, as presented in
Chapter I-4 in \cite{mac_lane_categories_2010}, to semicategories and
semifunctors.
›
locale is_ntsmcf =
𝒵 α +
vfsequence 𝔑 +
NTDom: is_semifunctor α 𝔄 𝔅 𝔉 +
NTCod: is_semifunctor α 𝔄 𝔅 𝔊
for α 𝔄 𝔅 𝔉 𝔊 𝔑 +
assumes ntsmcf_length[smc_cs_simps]: "vcard 𝔑 = 5⇩ℕ"
and ntsmcf_is_tdghm[slicing_intros]: "ntsmcf_tdghm 𝔑 :
smcf_dghm 𝔉 ↦⇩D⇩G⇩H⇩M smcf_dghm 𝔊 : smc_dg 𝔄 ↦↦⇩D⇩G⇘α⇙ smc_dg 𝔅"
and ntsmcf_NTDom[smc_cs_simps]: "𝔑⦇NTDom⦈ = 𝔉"
and ntsmcf_NTCod[smc_cs_simps]: "𝔑⦇NTCod⦈ = 𝔊"
and ntsmcf_NTDGDom[smc_cs_simps]: "𝔑⦇NTDGDom⦈ = 𝔄"
and ntsmcf_NTDGCod[smc_cs_simps]: "𝔑⦇NTDGCod⦈ = 𝔅"
and ntsmcf_Comp_commute[smc_cs_intros]: "f : a ↦⇘𝔄⇙ b ⟹
𝔑⦇NTMap⦈⦇b⦈ ∘⇩A⇘𝔅⇙ 𝔉⦇ArrMap⦈⦇f⦈ = 𝔊⦇ArrMap⦈⦇f⦈ ∘⇩A⇘𝔅⇙ 𝔑⦇NTMap⦈⦇a⦈"
syntax "_is_ntsmcf" :: "V ⇒ V ⇒ V ⇒ V ⇒ V ⇒ V ⇒ bool"
(‹(_ :/ _ ↦⇩S⇩M⇩C⇩F _ :/ _ ↦↦⇩S⇩M⇩Cı _)› [51, 51, 51, 51, 51] 51)
translations "𝔑 : 𝔉 ↦⇩S⇩M⇩C⇩F 𝔊 : 𝔄 ↦↦⇩S⇩M⇩C⇘α⇙ 𝔅" ⇌
"CONST is_ntsmcf α 𝔄 𝔅 𝔉 𝔊 𝔑"
abbreviation all_ntsmcfs :: "V ⇒ V"
where "all_ntsmcfs α ≡ set {𝔑. ∃𝔉 𝔊 𝔄 𝔅. 𝔑 : 𝔉 ↦⇩S⇩M⇩C⇩F 𝔊 : 𝔄 ↦↦⇩S⇩M⇩C⇘α⇙ 𝔅}"
abbreviation ntsmcfs :: "V ⇒ V ⇒ V ⇒ V"
where "ntsmcfs α 𝔄 𝔅 ≡ set {𝔑. ∃𝔉 𝔊. 𝔑 : 𝔉 ↦⇩S⇩M⇩C⇩F 𝔊 : 𝔄 ↦↦⇩S⇩M⇩C⇘α⇙ 𝔅}"
abbreviation these_ntsmcfs :: "V ⇒ V ⇒ V ⇒ V ⇒ V ⇒ V"
where "these_ntsmcfs α 𝔄 𝔅 𝔉 𝔊 ≡ set {𝔑. 𝔑 : 𝔉 ↦⇩S⇩M⇩C⇩F 𝔊 : 𝔄 ↦↦⇩S⇩M⇩C⇘α⇙ 𝔅}"
lemmas [smc_cs_simps] =
is_ntsmcf.ntsmcf_length
is_ntsmcf.ntsmcf_NTDom
is_ntsmcf.ntsmcf_NTCod
is_ntsmcf.ntsmcf_NTDGDom
is_ntsmcf.ntsmcf_NTDGCod
is_ntsmcf.ntsmcf_Comp_commute
lemmas [smc_cs_intros] = is_ntsmcf.ntsmcf_Comp_commute
lemma (in is_ntsmcf) ntsmcf_is_tdghm':
assumes "𝔉' = smcf_dghm 𝔉"
and "𝔊' = smcf_dghm 𝔊"
and "𝔄' = smc_dg 𝔄"
and "𝔅' = smc_dg 𝔅"
shows "ntsmcf_tdghm 𝔑 : 𝔉' ↦⇩D⇩G⇩H⇩M 𝔊' : 𝔄' ↦↦⇩D⇩G⇘α⇙ 𝔅'"
unfolding assms(1-4) by (rule ntsmcf_is_tdghm)
lemmas [slicing_intros] = is_ntsmcf.ntsmcf_is_tdghm'
text‹Rules.›
lemma (in is_ntsmcf) is_ntsmcf_axioms'[smc_cs_intros]:
assumes "α' = α" and "𝔄' = 𝔄" and "𝔅' = 𝔅" and "𝔉' = 𝔉" and "𝔊' = 𝔊"
shows "𝔑 : 𝔉' ↦⇩S⇩M⇩C⇩F 𝔊' : 𝔄' ↦↦⇩S⇩M⇩C⇘α'⇙ 𝔅'"
unfolding assms by (rule is_ntsmcf_axioms)
mk_ide rf is_ntsmcf_def[unfolded is_ntsmcf_axioms_def]
|intro is_ntsmcfI|
|dest is_ntsmcfD[dest]|
|elim is_ntsmcfE[elim]|
lemmas [smc_cs_intros] =
is_ntsmcfD(3,4)
lemma is_ntsmcfI':
assumes "𝒵 α"
and "vfsequence 𝔑"
and "𝔉 : 𝔄 ↦↦⇩S⇩M⇩C⇘α⇙ 𝔅"
and "𝔊 : 𝔄 ↦↦⇩S⇩M⇩C⇘α⇙ 𝔅"
and "vcard 𝔑 = 5⇩ℕ"
and "𝔑⦇NTDom⦈ = 𝔉"
and "𝔑⦇NTCod⦈ = 𝔊"
and "𝔑⦇NTDGDom⦈ = 𝔄"
and "𝔑⦇NTDGCod⦈ = 𝔅"
and "vsv (𝔑⦇NTMap⦈)"
and "𝒟⇩∘ (𝔑⦇NTMap⦈) = 𝔄⦇Obj⦈"
and "⋀a. a ∈⇩∘ 𝔄⦇Obj⦈ ⟹ 𝔑⦇NTMap⦈⦇a⦈ : 𝔉⦇ObjMap⦈⦇a⦈ ↦⇘𝔅⇙ 𝔊⦇ObjMap⦈⦇a⦈"
and "⋀a b f. f : a ↦⇘𝔄⇙ b ⟹
𝔑⦇NTMap⦈⦇b⦈ ∘⇩A⇘𝔅⇙ 𝔉⦇ArrMap⦈⦇f⦈ = 𝔊⦇ArrMap⦈⦇f⦈ ∘⇩A⇘𝔅⇙ 𝔑⦇NTMap⦈⦇a⦈"
shows "𝔑 : 𝔉 ↦⇩S⇩M⇩C⇩F 𝔊 : 𝔄 ↦↦⇩S⇩M⇩C⇘α⇙ 𝔅"
by (intro is_ntsmcfI is_tdghmI, unfold ntsmcf_tdghm_components slicing_simps)
(
simp_all add:
assms nat_omega_simps
ntsmcf_tdghm_def
is_semifunctorD(6)[OF assms(3)]
is_semifunctorD(6)[OF assms(4)]
)
lemma is_ntsmcfD':
assumes "𝔑 : 𝔉 ↦⇩S⇩M⇩C⇩F 𝔊 : 𝔄 ↦↦⇩S⇩M⇩C⇘α⇙ 𝔅"
shows "𝒵 α"
and "vfsequence 𝔑"
and "𝔉 : 𝔄 ↦↦⇩S⇩M⇩C⇘α⇙ 𝔅"
and "𝔊 : 𝔄 ↦↦⇩S⇩M⇩C⇘α⇙ 𝔅"
and "vcard 𝔑 = 5⇩ℕ"
and "𝔑⦇NTDom⦈ = 𝔉"
and "𝔑⦇NTCod⦈ = 𝔊"
and "𝔑⦇NTDGDom⦈ = 𝔄"
and "𝔑⦇NTDGCod⦈ = 𝔅"
and "vsv (𝔑⦇NTMap⦈)"
and "𝒟⇩∘ (𝔑⦇NTMap⦈) = 𝔄⦇Obj⦈"
and "⋀a. a ∈⇩∘ 𝔄⦇Obj⦈ ⟹ 𝔑⦇NTMap⦈⦇a⦈ : 𝔉⦇ObjMap⦈⦇a⦈ ↦⇘𝔅⇙ 𝔊⦇ObjMap⦈⦇a⦈"
and "⋀a b f. f : a ↦⇘𝔄⇙ b ⟹
𝔑⦇NTMap⦈⦇b⦈ ∘⇩A⇘𝔅⇙ 𝔉⦇ArrMap⦈⦇f⦈ = 𝔊⦇ArrMap⦈⦇f⦈ ∘⇩A⇘𝔅⇙ 𝔑⦇NTMap⦈⦇a⦈"
by
(
simp_all add:
is_ntsmcfD(2-11)[OF assms]
is_tdghmD[OF is_ntsmcfD(6)[OF assms], unfolded slicing_simps]
)
lemma is_ntsmcfE':
assumes "𝔑 : 𝔉 ↦⇩S⇩M⇩C⇩F 𝔊 : 𝔄 ↦↦⇩S⇩M⇩C⇘α⇙ 𝔅"
obtains "𝒵 α"
and "vfsequence 𝔑"
and "𝔉 : 𝔄 ↦↦⇩S⇩M⇩C⇘α⇙ 𝔅"
and "𝔊 : 𝔄 ↦↦⇩S⇩M⇩C⇘α⇙ 𝔅"
and "vcard 𝔑 = 5⇩ℕ"
and "𝔑⦇NTDom⦈ = 𝔉"
and "𝔑⦇NTCod⦈ = 𝔊"
and "𝔑⦇NTDGDom⦈ = 𝔄"
and "𝔑⦇NTDGCod⦈ = 𝔅"
and "vsv (𝔑⦇NTMap⦈)"
and "𝒟⇩∘ (𝔑⦇NTMap⦈) = 𝔄⦇Obj⦈"
and "⋀a. a ∈⇩∘ 𝔄⦇Obj⦈ ⟹ 𝔑⦇NTMap⦈⦇a⦈ : 𝔉⦇ObjMap⦈⦇a⦈ ↦⇘𝔅⇙ 𝔊⦇ObjMap⦈⦇a⦈"
and "⋀a b f. f : a ↦⇘𝔄⇙ b ⟹
𝔑⦇NTMap⦈⦇b⦈ ∘⇩A⇘𝔅⇙ 𝔉⦇ArrMap⦈⦇f⦈ = 𝔊⦇ArrMap⦈⦇f⦈ ∘⇩A⇘𝔅⇙ 𝔑⦇NTMap⦈⦇a⦈"
using assms by (simp add: is_ntsmcfD')
text‹Slicing.›
context is_ntsmcf
begin
interpretation tdghm: is_tdghm
α ‹smc_dg 𝔄› ‹smc_dg 𝔅› ‹smcf_dghm 𝔉› ‹smcf_dghm 𝔊› ‹ntsmcf_tdghm 𝔑›
by (rule ntsmcf_is_tdghm)
lemmas_with [unfolded slicing_simps]:
ntsmcf_NTMap_vsv = tdghm.tdghm_NTMap_vsv
and ntsmcf_NTMap_vdomain[smc_cs_simps] = tdghm.tdghm_NTMap_vdomain
and ntsmcf_NTMap_is_arr = tdghm.tdghm_NTMap_is_arr
and ntsmcf_NTMap_is_arr'[smc_cs_intros] = tdghm.tdghm_NTMap_is_arr'
sublocale NTMap: vsv ‹𝔑⦇NTMap⦈›
rewrites "𝒟⇩∘ (𝔑⦇NTMap⦈) = 𝔄⦇Obj⦈"
by (rule ntsmcf_NTMap_vsv) (simp add: smc_cs_simps)
lemmas_with [unfolded slicing_simps]:
ntsmcf_NTMap_app_in_Arr[smc_cs_intros] = tdghm.tdghm_NTMap_app_in_Arr
and ntsmcf_NTMap_vrange_vifunion = tdghm.tdghm_NTMap_vrange_vifunion
and ntsmcf_NTMap_vrange = tdghm.tdghm_NTMap_vrange
and ntsmcf_NTMap_vsubset_Vset = tdghm.tdghm_NTMap_vsubset_Vset
and ntsmcf_NTMap_in_Vset = tdghm.tdghm_NTMap_in_Vset
and ntsmcf_is_tdghm_if_ge_Limit = tdghm.tdghm_is_tdghm_if_ge_Limit
end
lemmas [smc_cs_intros] = is_ntsmcf.ntsmcf_NTMap_is_arr'
lemma (in is_ntsmcf) ntsmcf_Comp_commute':
assumes "f : a ↦⇘𝔄⇙ b" and "g : c ↦⇘𝔅⇙ 𝔉⦇ObjMap⦈⦇a⦈"
shows
"𝔑⦇NTMap⦈⦇b⦈ ∘⇩A⇘𝔅⇙ (𝔉⦇ArrMap⦈⦇f⦈ ∘⇩A⇘𝔅⇙ g) =
(𝔊⦇ArrMap⦈⦇f⦈ ∘⇩A⇘𝔅⇙ 𝔑⦇NTMap⦈⦇a⦈) ∘⇩A⇘𝔅⇙ g"
using assms
by
(
cs_concl
cs_simp: ntsmcf_Comp_commute semicategory.smc_Comp_assoc[symmetric]
cs_intro: smc_cs_intros
)
lemma (in is_ntsmcf) ntsmcf_Comp_commute'':
assumes "f : a ↦⇘𝔄⇙ b" and "g : c ↦⇘𝔅⇙ 𝔉⦇ObjMap⦈⦇a⦈"
shows
"𝔊⦇ArrMap⦈⦇f⦈ ∘⇩A⇘𝔅⇙ (𝔑⦇NTMap⦈⦇a⦈ ∘⇩A⇘𝔅⇙ g) =
(𝔑⦇NTMap⦈⦇b⦈ ∘⇩A⇘𝔅⇙ 𝔉⦇ArrMap⦈⦇f⦈) ∘⇩A⇘𝔅⇙ g"
using assms
by
(
cs_concl
cs_simp: ntsmcf_Comp_commute semicategory.smc_Comp_assoc[symmetric]
cs_intro: smc_cs_intros
)
text‹Elementary properties.›
lemma ntsmcf_eqI:
assumes "𝔑 : 𝔉 ↦⇩S⇩M⇩C⇩F 𝔊 : 𝔄 ↦↦⇩S⇩M⇩C⇘α⇙ 𝔅"
and "𝔑' : 𝔉' ↦⇩S⇩M⇩C⇩F 𝔊' : 𝔄' ↦↦⇩S⇩M⇩C⇘α⇙ 𝔅'"
and "𝔑⦇NTMap⦈ = 𝔑'⦇NTMap⦈"
and "𝔉 = 𝔉'"
and "𝔊 = 𝔊'"
and "𝔄 = 𝔄'"
and "𝔅 = 𝔅'"
shows "𝔑 = 𝔑'"
proof-
interpret L: is_ntsmcf α 𝔄 𝔅 𝔉 𝔊 𝔑 by (rule assms(1))
interpret R: is_ntsmcf α 𝔄' 𝔅' 𝔉' 𝔊' 𝔑' by (rule assms(2))
show ?thesis
proof(rule vsv_eqI)
have dom: "𝒟⇩∘ 𝔑 = 5⇩ℕ" by (cs_concl cs_simp: smc_cs_simps V_cs_simps)
show "𝒟⇩∘ 𝔑 = 𝒟⇩∘ 𝔑'" by (cs_concl cs_simp: smc_cs_simps V_cs_simps)
from assms(4-7) have sup:
"𝔑⦇NTDom⦈ = 𝔑'⦇NTDom⦈" "𝔑⦇NTCod⦈ = 𝔑'⦇NTCod⦈"
"𝔑⦇NTDGDom⦈ = 𝔑'⦇NTDGDom⦈" "𝔑⦇NTDGCod⦈ = 𝔑'⦇NTDGCod⦈"
by (simp_all add: smc_cs_simps)
show "a ∈⇩∘ 𝒟⇩∘ 𝔑 ⟹ 𝔑⦇a⦈ = 𝔑'⦇a⦈" for a
by (unfold dom, elim_in_numeral, insert assms(3) sup)
(auto simp: nt_field_simps)
qed auto
qed
lemma ntsmcf_tdghm_eqI:
assumes "𝔑 : 𝔉 ↦⇩S⇩M⇩C⇩F 𝔊 : 𝔄 ↦↦⇩S⇩M⇩C⇘α⇙ 𝔅"
and "𝔑' : 𝔉' ↦⇩S⇩M⇩C⇩F 𝔊' : 𝔄' ↦↦⇩S⇩M⇩C⇘α⇙ 𝔅'"
and "𝔉 = 𝔉'"
and "𝔊 = 𝔊'"
and "𝔄 = 𝔄'"
and "𝔅 = 𝔅'"
and "ntsmcf_tdghm 𝔑 = ntsmcf_tdghm 𝔑'"
shows "𝔑 = 𝔑'"
proof(rule ntsmcf_eqI[of α])
from assms(7) have "ntsmcf_tdghm 𝔑⦇NTMap⦈ = ntsmcf_tdghm 𝔑'⦇NTMap⦈" by simp
then show "𝔑⦇NTMap⦈ = 𝔑'⦇NTMap⦈" unfolding slicing_simps by simp_all
from assms(3-6) show "𝔉 = 𝔉'" "𝔊 = 𝔊'" "𝔄 = 𝔄'" "𝔅 = 𝔅'" by simp_all
qed (simp_all add: assms(1,2))
lemma (in is_ntsmcf) ntsmcf_def:
"𝔑 = [𝔑⦇NTMap⦈, 𝔑⦇NTDom⦈, 𝔑⦇NTCod⦈, 𝔑⦇NTDGDom⦈, 𝔑⦇NTDGCod⦈]⇩∘"
proof(rule vsv_eqI)
have dom_lhs: "𝒟⇩∘ 𝔑 = 5⇩ℕ" by (cs_concl cs_simp: smc_cs_simps V_cs_simps)
have dom_rhs:
"𝒟⇩∘ [𝔑⦇NTMap⦈, 𝔑⦇NTDGDom⦈, 𝔑⦇NTDGCod⦈, 𝔑⦇NTDom⦈, 𝔑⦇NTCod⦈]⇩∘ = 5⇩ℕ"
by (simp add: nat_omega_simps)
then show "𝒟⇩∘ 𝔑 = 𝒟⇩∘ [𝔑⦇NTMap⦈, 𝔑⦇NTDom⦈, 𝔑⦇NTCod⦈, 𝔑⦇NTDGDom⦈, 𝔑⦇NTDGCod⦈]⇩∘"
unfolding dom_lhs dom_rhs by (simp add: nat_omega_simps)
show "a ∈⇩∘ 𝒟⇩∘ 𝔑 ⟹
𝔑⦇a⦈ = [𝔑⦇NTMap⦈, 𝔑⦇NTDom⦈, 𝔑⦇NTCod⦈, 𝔑⦇NTDGDom⦈, 𝔑⦇NTDGCod⦈]⇩∘⦇a⦈"
for a
by (unfold dom_lhs, elim_in_numeral, unfold nt_field_simps)
(simp_all add: nat_omega_simps)
qed (auto simp: vsv_axioms)
text‹Size.›
lemma (in is_ntsmcf) ntsmcf_in_Vset:
assumes "𝒵 β" and "α ∈⇩∘ β"
shows "𝔑 ∈⇩∘ Vset β"
proof-
interpret β: 𝒵 β by (rule assms(1))
note [smc_cs_intros] =
ntsmcf_NTMap_in_Vset
NTDom.smcf_in_Vset
NTCod.smcf_in_Vset
NTDom.HomDom.smc_in_Vset
NTDom.HomCod.smc_in_Vset
from assms(2) show ?thesis
by (subst ntsmcf_def)
(cs_concl cs_simp: smc_cs_simps cs_intro: smc_cs_intros V_cs_intros)
qed
lemma (in is_ntsmcf) ntsmcf_is_ntsmcf_if_ge_Limit:
assumes "𝒵 β" and "α ∈⇩∘ β"
shows "𝔑 : 𝔉 ↦⇩S⇩M⇩C⇩F 𝔊 : 𝔄 ↦↦⇩S⇩M⇩C⇘β⇙ 𝔅"
proof(intro is_ntsmcfI )
show "ntsmcf_tdghm 𝔑 :
smcf_dghm 𝔉 ↦⇩D⇩G⇩H⇩M smcf_dghm 𝔊 : smc_dg 𝔄 ↦↦⇩D⇩G⇘β⇙ smc_dg 𝔅"
by (rule is_tdghm.tdghm_is_tdghm_if_ge_Limit[OF ntsmcf_is_tdghm assms])
show "𝔑⦇NTMap⦈⦇b⦈ ∘⇩A⇘𝔅⇙ 𝔉⦇ArrMap⦈⦇f⦈ = 𝔊⦇ArrMap⦈⦇f⦈ ∘⇩A⇘𝔅⇙ 𝔑⦇NTMap⦈⦇a⦈"
if "f : a ↦⇘𝔄⇙ b" for f a b
using that by (cs_concl cs_simp: smc_cs_simps cs_intro: smc_cs_intros)+
qed
(
cs_concl
cs_simp: smc_cs_simps
cs_intro:
smc_cs_intros
V_cs_intros
assms
NTDom.smcf_is_semifunctor_if_ge_Limit
NTCod.smcf_is_semifunctor_if_ge_Limit
)+
lemma small_all_ntsmcfs[simp]:
"small {𝔑. ∃𝔉 𝔊 𝔄 𝔅. 𝔑 : 𝔉 ↦⇩S⇩M⇩C⇩F 𝔊 : 𝔄 ↦↦⇩S⇩M⇩C⇘α⇙ 𝔅}"
proof(cases ‹𝒵 α›)
case True
from is_ntsmcf.ntsmcf_in_Vset show ?thesis
by (intro down[of _ ‹Vset (α + ω)›])
(auto simp: True 𝒵.𝒵_Limit_αω 𝒵.𝒵_ω_αω 𝒵.intro 𝒵.𝒵_α_αω)
next
case False
then have "{𝔑. ∃𝔉 𝔊 𝔄 𝔅. 𝔑 : 𝔉 ↦⇩S⇩M⇩C⇩F 𝔊 : 𝔄 ↦↦⇩S⇩M⇩C⇘α⇙ 𝔅} = {}" by auto
then show ?thesis by simp
qed
lemma small_ntsmcfs[simp]: "small {𝔑. ∃𝔉 𝔊. 𝔑 : 𝔉 ↦⇩S⇩M⇩C⇩F 𝔊 : 𝔄 ↦↦⇩S⇩M⇩C⇘α⇙ 𝔅}"
by (rule down[of _ ‹set {𝔑. ∃𝔉 𝔊 𝔄 𝔅. 𝔑 : 𝔉 ↦⇩S⇩M⇩C⇩F 𝔊 : 𝔄 ↦↦⇩S⇩M⇩C⇘α⇙ 𝔅}›])
auto
lemma small_these_ntcfs[simp]: "small {𝔑. 𝔑 : 𝔉 ↦⇩S⇩M⇩C⇩F 𝔊 : 𝔄 ↦↦⇩S⇩M⇩C⇘α⇙ 𝔅}"
by (rule down[of _ ‹set {𝔑. ∃𝔉 𝔊 𝔄 𝔅. 𝔑 : 𝔉 ↦⇩S⇩M⇩C⇩F 𝔊 : 𝔄 ↦↦⇩S⇩M⇩C⇘α⇙ 𝔅}›])
auto
text‹Further elementary results.›
lemma these_ntsmcfs_iff:
"𝔑 ∈⇩∘ these_ntsmcfs α 𝔄 𝔅 𝔉 𝔊 ⟷ 𝔑 : 𝔉 ↦⇩S⇩M⇩C⇩F 𝔊 : 𝔄 ↦↦⇩S⇩M⇩C⇘α⇙ 𝔅"
by auto
subsection‹Opposite natural transformation of semifunctors›
subsubsection‹Definition and elementary properties›
text‹See section 1.5 in \cite{bodo_categories_1970}.›
definition op_ntsmcf :: "V ⇒ V"
where "op_ntsmcf 𝔑 =
[
𝔑⦇NTMap⦈,
op_smcf (𝔑⦇NTCod⦈),
op_smcf (𝔑⦇NTDom⦈),
op_smc (𝔑⦇NTDGDom⦈),
op_smc (𝔑⦇NTDGCod⦈)
]⇩∘"
text‹Components.›
lemma op_ntsmcf_components[smc_op_simps]:
shows "op_ntsmcf 𝔑⦇NTMap⦈ = 𝔑⦇NTMap⦈"
and "op_ntsmcf 𝔑⦇NTDom⦈ = op_smcf (𝔑⦇NTCod⦈)"
and "op_ntsmcf 𝔑⦇NTCod⦈ = op_smcf (𝔑⦇NTDom⦈)"
and "op_ntsmcf 𝔑⦇NTDGDom⦈ = op_smc (𝔑⦇NTDGDom⦈)"
and "op_ntsmcf 𝔑⦇NTDGCod⦈ = op_smc (𝔑⦇NTDGCod⦈)"
unfolding op_ntsmcf_def nt_field_simps by (auto simp: nat_omega_simps)
text‹Slicing.›
lemma op_tdghm_ntsmcf_tdghm[slicing_commute]:
"op_tdghm (ntsmcf_tdghm 𝔑) = ntsmcf_tdghm (op_ntsmcf 𝔑)"
proof(rule vsv_eqI)
have dom_lhs: "𝒟⇩∘ (op_tdghm (ntsmcf_tdghm 𝔑)) = 5⇩ℕ"
unfolding op_tdghm_def by (auto simp: nat_omega_simps)
have dom_rhs: "𝒟⇩∘ (ntsmcf_tdghm (op_ntsmcf 𝔑)) = 5⇩ℕ"
unfolding ntsmcf_tdghm_def by (auto simp: nat_omega_simps)
show "𝒟⇩∘ (op_tdghm (ntsmcf_tdghm 𝔑)) = 𝒟⇩∘ (ntsmcf_tdghm (op_ntsmcf 𝔑))"
unfolding dom_lhs dom_rhs by simp
show "a ∈⇩∘ 𝒟⇩∘ (op_tdghm (ntsmcf_tdghm 𝔑)) ⟹
op_tdghm (ntsmcf_tdghm 𝔑)⦇a⦈ = ntsmcf_tdghm (op_ntsmcf 𝔑)⦇a⦈"
for a
by
(
unfold dom_lhs,
elim_in_numeral,
unfold ntsmcf_tdghm_def op_ntsmcf_def op_tdghm_def nt_field_simps
)
(auto simp: nat_omega_simps slicing_commute[symmetric])
qed (auto simp: ntsmcf_tdghm_def op_tdghm_def)
subsubsection‹Further properties›
lemma (in is_ntsmcf) is_ntsmcf_op:
"op_ntsmcf 𝔑 : op_smcf 𝔊 ↦⇩S⇩M⇩C⇩F op_smcf 𝔉 : op_smc 𝔄 ↦↦⇩S⇩M⇩C⇘α⇙ op_smc 𝔅"
proof(rule is_ntsmcfI, unfold smc_op_simps)
show "vfsequence (op_ntsmcf 𝔑)" by (simp add: op_ntsmcf_def)
show "vcard (op_ntsmcf 𝔑) = 5⇩ℕ" by (simp add: op_ntsmcf_def nat_omega_simps)
fix f a b assume "f : b ↦⇘𝔄⇙ a"
with is_ntsmcf_axioms show
"𝔑⦇NTMap⦈⦇b⦈ ∘⇩A⇘op_smc 𝔅⇙ 𝔊⦇ArrMap⦈⦇f⦈ =
𝔉⦇ArrMap⦈⦇f⦈ ∘⇩A⇘op_smc 𝔅⇙ 𝔑⦇NTMap⦈⦇a⦈"
by (cs_concl cs_simp: smc_cs_simps smc_op_simps cs_intro: smc_cs_intros)
qed
(
insert is_ntsmcf_axioms,
(
cs_concl
cs_simp: smc_cs_simps slicing_commute[symmetric]
cs_intro: smc_cs_intros smc_op_intros dg_op_intros slicing_intros
)+
)
lemma (in is_ntsmcf) is_ntsmcf_op'[smc_op_intros]:
assumes "𝔊' = op_smcf 𝔊"
and "𝔉' = op_smcf 𝔉"
and "𝔄' = op_smc 𝔄"
and "𝔅' = op_smc 𝔅"
shows "op_ntsmcf 𝔑 : 𝔊' ↦⇩S⇩M⇩C⇩F 𝔉' : 𝔄' ↦↦⇩S⇩M⇩C⇘α⇙ 𝔅'"
unfolding assms by (rule is_ntsmcf_op)
lemmas [smc_op_intros] = is_ntsmcf.is_ntsmcf_op'
lemma (in is_ntsmcf) ntsmcf_op_ntsmcf_op_ntsmcf[smc_op_simps]:
"op_ntsmcf (op_ntsmcf 𝔑) = 𝔑"
proof(rule ntsmcf_eqI[of α 𝔄 𝔅 𝔉 𝔊 _ 𝔄 𝔅 𝔉 𝔊], unfold smc_op_simps)
interpret op:
is_ntsmcf α ‹op_smc 𝔄› ‹op_smc 𝔅› ‹op_smcf 𝔊› ‹op_smcf 𝔉› ‹op_ntsmcf 𝔑›
by (rule is_ntsmcf_op)
from op.is_ntsmcf_op show
"op_ntsmcf (op_ntsmcf 𝔑) : 𝔉 ↦⇩S⇩M⇩C⇩F 𝔊 : 𝔄 ↦↦⇩S⇩M⇩C⇘α⇙ 𝔅"
by (simp add: smc_op_simps)
qed (auto simp: smc_cs_intros)
lemmas ntsmcf_op_ntsmcf_op_ntsmcf[smc_op_simps] =
is_ntsmcf.ntsmcf_op_ntsmcf_op_ntsmcf
lemma eq_op_ntsmcf_iff:
assumes "𝔑 : 𝔉 ↦⇩S⇩M⇩C⇩F 𝔊 : 𝔄 ↦↦⇩S⇩M⇩C⇘α⇙ 𝔅"
and "𝔑' : 𝔉' ↦⇩S⇩M⇩C⇩F 𝔊' : 𝔄' ↦↦⇩S⇩M⇩C⇘α⇙ 𝔅'"
shows "op_ntsmcf 𝔑 = op_ntsmcf 𝔑' ⟷ 𝔑 = 𝔑'"
proof
interpret L: is_ntsmcf α 𝔄 𝔅 𝔉 𝔊 𝔑 by (rule assms(1))
interpret R: is_ntsmcf α 𝔄' 𝔅' 𝔉' 𝔊' 𝔑' by (rule assms(2))
assume prems: "op_ntsmcf 𝔑 = op_ntsmcf 𝔑'"
show "𝔑 = 𝔑'"
proof(rule ntsmcf_eqI[OF assms])
from prems L.ntsmcf_op_ntsmcf_op_ntsmcf R.ntsmcf_op_ntsmcf_op_ntsmcf show
"𝔑⦇NTMap⦈ = 𝔑'⦇NTMap⦈"
by metis+
from prems L.ntsmcf_op_ntsmcf_op_ntsmcf R.ntsmcf_op_ntsmcf_op_ntsmcf
have "𝔑⦇NTDom⦈ = 𝔑'⦇NTDom⦈"
and "𝔑⦇NTCod⦈ = 𝔑'⦇NTCod⦈"
and "𝔑⦇NTDGDom⦈ = 𝔑'⦇NTDGDom⦈"
and "𝔑⦇NTDGCod⦈ = 𝔑'⦇NTDGCod⦈"
by metis+
then show "𝔉 = 𝔉'" "𝔊 = 𝔊'" "𝔄 = 𝔄'" "𝔅 = 𝔅'" by (auto simp: smc_cs_simps)
qed
qed auto
subsection‹Vertical composition of natural transformations›
subsubsection‹Definition and elementary properties›
text‹See Chapter II-4 in \cite{mac_lane_categories_2010}.›
definition ntsmcf_vcomp :: "V ⇒ V ⇒ V" (infixl ‹∙⇩N⇩T⇩S⇩M⇩C⇩F› 55)
where "ntsmcf_vcomp 𝔐 𝔑 =
[
(λa∈⇩∘𝔑⦇NTDGDom⦈⦇Obj⦈. (𝔐⦇NTMap⦈⦇a⦈) ∘⇩A⇘𝔑⦇NTDGCod⦈⇙ (𝔑⦇NTMap⦈⦇a⦈)),
𝔑⦇NTDom⦈,
𝔐⦇NTCod⦈,
𝔑⦇NTDGDom⦈,
𝔐⦇NTDGCod⦈
]⇩∘"
text‹Components.›
lemma ntsmcf_vcomp_components:
shows
"(𝔐 ∙⇩N⇩T⇩S⇩M⇩C⇩F 𝔑)⦇NTMap⦈ =
(λa∈⇩∘𝔑⦇NTDGDom⦈⦇Obj⦈. (𝔐⦇NTMap⦈⦇a⦈) ∘⇩A⇘𝔑⦇NTDGCod⦈⇙ (𝔑⦇NTMap⦈⦇a⦈))"
and [dg_shared_cs_simps, smc_cs_simps]: "(𝔐 ∙⇩N⇩T⇩S⇩M⇩C⇩F 𝔑)⦇NTDom⦈ = 𝔑⦇NTDom⦈"
and [dg_shared_cs_simps, smc_cs_simps]: "(𝔐 ∙⇩N⇩T⇩S⇩M⇩C⇩F 𝔑)⦇NTCod⦈ = 𝔐⦇NTCod⦈"
and [dg_shared_cs_simps, smc_cs_simps]:
"(𝔐 ∙⇩N⇩T⇩S⇩M⇩C⇩F 𝔑)⦇NTDGDom⦈ = 𝔑⦇NTDGDom⦈"
and [dg_shared_cs_simps, smc_cs_simps]:
"(𝔐 ∙⇩N⇩T⇩S⇩M⇩C⇩F 𝔑)⦇NTDGCod⦈ = 𝔐⦇NTDGCod⦈"
unfolding nt_field_simps ntsmcf_vcomp_def by (simp_all add: nat_omega_simps)
subsubsection‹Natural transformation map›
lemma ntsmcf_vcomp_NTMap_vsv[dg_shared_cs_intros, smc_cs_intros]:
"vsv ((𝔐 ∙⇩N⇩T⇩S⇩M⇩C⇩F 𝔑)⦇NTMap⦈)"
unfolding ntsmcf_vcomp_components by simp
lemma ntsmcf_vcomp_NTMap_vdomain[smc_cs_simps]:
assumes "𝔑 : 𝔉 ↦⇩S⇩M⇩C⇩F 𝔊 : 𝔄 ↦↦⇩S⇩M⇩C⇘α⇙ 𝔅"
shows "𝒟⇩∘ ((𝔐 ∙⇩N⇩T⇩S⇩M⇩C⇩F 𝔑)⦇NTMap⦈) = 𝔄⦇Obj⦈"
proof-
interpret 𝔑: is_ntsmcf α 𝔄 𝔅 𝔉 𝔊 𝔑 using assms by auto
show ?thesis unfolding ntsmcf_vcomp_components by (simp add: smc_cs_simps)
qed
lemma ntsmcf_vcomp_NTMap_app[smc_cs_simps]:
assumes "𝔐 : 𝔊 ↦⇩S⇩M⇩C⇩F ℌ : 𝔄 ↦↦⇩S⇩M⇩C⇘α⇙ 𝔅"
and "𝔑 : 𝔉 ↦⇩S⇩M⇩C⇩F 𝔊 : 𝔄 ↦↦⇩S⇩M⇩C⇘α⇙ 𝔅"
and "a ∈⇩∘ 𝔄⦇Obj⦈"
shows "(𝔐 ∙⇩N⇩T⇩S⇩M⇩C⇩F 𝔑)⦇NTMap⦈⦇a⦈ = 𝔐⦇NTMap⦈⦇a⦈ ∘⇩A⇘𝔅⇙ 𝔑⦇NTMap⦈⦇a⦈"
proof-
interpret 𝔐: is_ntsmcf α 𝔄 𝔅 𝔊 ℌ 𝔐 using assms by auto
interpret 𝔑: is_ntsmcf α 𝔄 𝔅 𝔉 𝔊 𝔑 using assms by auto
from assms show ?thesis
unfolding ntsmcf_vcomp_components by (simp add: smc_cs_simps)
qed
lemma ntsmcf_vcomp_NTMap_vrange:
assumes "𝔐 : 𝔊 ↦⇩S⇩M⇩C⇩F ℌ : 𝔄 ↦↦⇩S⇩M⇩C⇘α⇙ 𝔅"
and "𝔑 : 𝔉 ↦⇩S⇩M⇩C⇩F 𝔊 : 𝔄 ↦↦⇩S⇩M⇩C⇘α⇙ 𝔅"
shows "ℛ⇩∘ ((𝔐 ∙⇩N⇩T⇩S⇩M⇩C⇩F 𝔑)⦇NTMap⦈) ⊆⇩∘ 𝔅⦇Arr⦈"
unfolding ntsmcf_vcomp_components
proof(rule vrange_VLambda_vsubset)
fix x assume prems: "x ∈⇩∘ 𝔑⦇NTDGDom⦈⦇Obj⦈"
from prems assms show "𝔐⦇NTMap⦈⦇x⦈ ∘⇩A⇘𝔑⦇NTDGCod⦈⇙ 𝔑⦇NTMap⦈⦇x⦈ ∈⇩∘ 𝔅⦇Arr⦈"
by (cs_prems cs_simp: smc_cs_simps cs_intro: smc_cs_intros)
(cs_concl cs_simp: smc_cs_simps cs_intro: smc_cs_intros)
qed
subsubsection‹Further properties›
lemma ntsmcf_vcomp_composable_commute[smc_cs_simps]:
assumes "𝔐 : 𝔊 ↦⇩S⇩M⇩C⇩F ℌ : 𝔄 ↦↦⇩S⇩M⇩C⇘α⇙ 𝔅"
and "𝔑 : 𝔉 ↦⇩S⇩M⇩C⇩F 𝔊 : 𝔄 ↦↦⇩S⇩M⇩C⇘α⇙ 𝔅"
and "f : a ↦⇘𝔄⇙ b"
shows
"(𝔐⦇NTMap⦈⦇b⦈ ∘⇩A⇘𝔅⇙ 𝔑⦇NTMap⦈⦇b⦈) ∘⇩A⇘𝔅⇙ 𝔉⦇ArrMap⦈⦇f⦈ =
ℌ⦇ArrMap⦈⦇f⦈ ∘⇩A⇘𝔅⇙ (𝔐⦇NTMap⦈⦇a⦈ ∘⇩A⇘𝔅⇙ 𝔑⦇NTMap⦈⦇a⦈)"
(is ‹(?MC ∘⇩A⇘𝔅⇙ ?NC) ∘⇩A⇘𝔅⇙ ?R = ?T ∘⇩A⇘𝔅⇙ (?MD ∘⇩A⇘𝔅⇙ ?ND)›)
proof-
interpret 𝔐: is_ntsmcf α 𝔄 𝔅 𝔊 ℌ 𝔐 by (rule assms(1))
interpret 𝔑: is_ntsmcf α 𝔄 𝔅 𝔉 𝔊 𝔑 by (rule assms(2))
from assms show ?thesis
by (intro 𝔐.NTDom.HomCod.smc_pattern_rectangle_left)
(cs_concl cs_intro: smc_cs_intros cs_simp: 𝔑.ntsmcf_Comp_commute)
qed
lemma ntsmcf_vcomp_is_ntsmcf[smc_cs_intros]:
assumes "𝔐 : 𝔊 ↦⇩S⇩M⇩C⇩F ℌ : 𝔄 ↦↦⇩S⇩M⇩C⇘α⇙ 𝔅"
and "𝔑 : 𝔉 ↦⇩S⇩M⇩C⇩F 𝔊 : 𝔄 ↦↦⇩S⇩M⇩C⇘α⇙ 𝔅"
shows "𝔐 ∙⇩N⇩T⇩S⇩M⇩C⇩F 𝔑 : 𝔉 ↦⇩S⇩M⇩C⇩F ℌ : 𝔄 ↦↦⇩S⇩M⇩C⇘α⇙ 𝔅"
proof-
interpret 𝔐: is_ntsmcf α 𝔄 𝔅 𝔊 ℌ 𝔐 by (rule assms(1))
interpret 𝔑: is_ntsmcf α 𝔄 𝔅 𝔉 𝔊 𝔑 by (rule assms(2))
show ?thesis
proof(intro is_ntsmcfI')
show "vfsequence (𝔐 ∙⇩N⇩T⇩S⇩M⇩C⇩F 𝔑)" by (simp add: ntsmcf_vcomp_def)
show "vcard (𝔐 ∙⇩N⇩T⇩S⇩M⇩C⇩F 𝔑) = 5⇩ℕ"
by (auto simp: nat_omega_simps ntsmcf_vcomp_def)
show "vsv ((𝔐 ∙⇩N⇩T⇩S⇩M⇩C⇩F 𝔑)⦇NTMap⦈)"
unfolding ntsmcf_vcomp_components by simp
from assms show "(𝔐 ∙⇩N⇩T⇩S⇩M⇩C⇩F 𝔑)⦇NTMap⦈⦇a⦈ : 𝔉⦇ObjMap⦈⦇a⦈ ↦⇘𝔅⇙ ℌ⦇ObjMap⦈⦇a⦈"
if "a ∈⇩∘ 𝔄⦇Obj⦈" for a
using that by (cs_concl cs_simp: smc_cs_simps cs_intro: smc_cs_intros)
fix f a b assume "f : a ↦⇘𝔄⇙ b"
with assms show
"(𝔐 ∙⇩N⇩T⇩S⇩M⇩C⇩F 𝔑)⦇NTMap⦈⦇b⦈ ∘⇩A⇘𝔅⇙ 𝔉⦇ArrMap⦈⦇f⦈ =
ℌ⦇ArrMap⦈⦇f⦈ ∘⇩A⇘𝔅⇙ (𝔐 ∙⇩N⇩T⇩S⇩M⇩C⇩F 𝔑)⦇NTMap⦈⦇a⦈"
by
(
cs_concl
cs_simp: smc_cs_simps is_ntsmcf.ntsmcf_Comp_commute'
cs_intro: smc_cs_intros
)
qed (use assms in ‹auto simp: smc_cs_simps ntsmcf_vcomp_NTMap_vrange›)
qed
lemma ntsmcf_vcomp_assoc[smc_cs_simps]:
assumes "𝔏 : ℌ ↦⇩S⇩M⇩C⇩F 𝔎 : 𝔄 ↦↦⇩S⇩M⇩C⇘α⇙ 𝔅"
and "𝔐 : 𝔊 ↦⇩S⇩M⇩C⇩F ℌ : 𝔄 ↦↦⇩S⇩M⇩C⇘α⇙ 𝔅"
and "𝔑 : 𝔉 ↦⇩S⇩M⇩C⇩F 𝔊 : 𝔄 ↦↦⇩S⇩M⇩C⇘α⇙ 𝔅"
shows "(𝔏 ∙⇩N⇩T⇩S⇩M⇩C⇩F 𝔐) ∙⇩N⇩T⇩S⇩M⇩C⇩F 𝔑 = 𝔏 ∙⇩N⇩T⇩S⇩M⇩C⇩F (𝔐 ∙⇩N⇩T⇩S⇩M⇩C⇩F 𝔑)"
proof-
interpret 𝔏: is_ntsmcf α 𝔄 𝔅 ℌ 𝔎 𝔏 by (rule assms(1))
interpret 𝔐: is_ntsmcf α 𝔄 𝔅 𝔊 ℌ 𝔐 by (rule assms(2))
interpret 𝔑: is_ntsmcf α 𝔄 𝔅 𝔉 𝔊 𝔑 by (rule assms(3))
show ?thesis
proof(rule ntsmcf_eqI[of α])
show "((𝔏 ∙⇩N⇩T⇩S⇩M⇩C⇩F 𝔐) ∙⇩N⇩T⇩S⇩M⇩C⇩F 𝔑)⦇NTMap⦈ = (𝔏 ∙⇩N⇩T⇩S⇩M⇩C⇩F (𝔐 ∙⇩N⇩T⇩S⇩M⇩C⇩F 𝔑))⦇NTMap⦈"
proof(rule vsv_eqI)
fix a assume "a ∈⇩∘ 𝒟⇩∘ ((𝔏 ∙⇩N⇩T⇩S⇩M⇩C⇩F 𝔐 ∙⇩N⇩T⇩S⇩M⇩C⇩F 𝔑)⦇NTMap⦈)"
then have "a ∈⇩∘ 𝔄⦇Obj⦈"
unfolding ntsmcf_vcomp_components by (simp add: smc_cs_simps)
with assms show
"((𝔏 ∙⇩N⇩T⇩S⇩M⇩C⇩F 𝔐) ∙⇩N⇩T⇩S⇩M⇩C⇩F 𝔑)⦇NTMap⦈⦇a⦈ =
(𝔏 ∙⇩N⇩T⇩S⇩M⇩C⇩F (𝔐 ∙⇩N⇩T⇩S⇩M⇩C⇩F 𝔑))⦇NTMap⦈⦇a⦈"
by (cs_concl cs_simp: smc_cs_simps cs_intro: smc_cs_intros)
qed (simp_all add: ntsmcf_vcomp_components)
qed (auto intro: smc_cs_intros)
qed
subsubsection‹
Opposite of the vertical composition of natural transformations
of semifunctors
›
lemma op_ntsmcf_ntsmcf_vcomp[smc_op_simps]:
assumes "𝔐 : 𝔊 ↦⇩S⇩M⇩C⇩F ℌ : 𝔄 ↦↦⇩S⇩M⇩C⇘α⇙ 𝔅"
and "𝔑 : 𝔉 ↦⇩S⇩M⇩C⇩F 𝔊 : 𝔄 ↦↦⇩S⇩M⇩C⇘α⇙ 𝔅"
shows "op_ntsmcf (𝔐 ∙⇩N⇩T⇩S⇩M⇩C⇩F 𝔑) = op_ntsmcf 𝔑 ∙⇩N⇩T⇩S⇩M⇩C⇩F op_ntsmcf 𝔐"
proof-
interpret 𝔐: is_ntsmcf α 𝔄 𝔅 𝔊 ℌ 𝔐 using assms(1) by auto
interpret 𝔑: is_ntsmcf α 𝔄 𝔅 𝔉 𝔊 𝔑 using assms(2) by auto
show ?thesis
proof(rule ntsmcf_eqI[of α]; (intro symmetric)?)
show "op_ntsmcf (𝔐 ∙⇩N⇩T⇩S⇩M⇩C⇩F 𝔑)⦇NTMap⦈ =
(op_ntsmcf 𝔑 ∙⇩N⇩T⇩S⇩M⇩C⇩F op_ntsmcf 𝔐)⦇NTMap⦈"
proof(rule vsv_eqI)
fix a assume "a ∈⇩∘ 𝒟⇩∘ (op_ntsmcf (𝔐 ∙⇩N⇩T⇩S⇩M⇩C⇩F 𝔑)⦇NTMap⦈)"
then have a: "a ∈⇩∘ 𝔄⦇Obj⦈"
unfolding smc_op_simps ntsmcf_vcomp_NTMap_vdomain[OF assms(2)] by simp
with
𝔐.NTDom.HomCod.op_smc_Comp
𝔐.ntsmcf_NTMap_is_arr[OF a]
𝔑.ntsmcf_NTMap_is_arr[OF a]
show "op_ntsmcf (𝔐 ∙⇩N⇩T⇩S⇩M⇩C⇩F 𝔑)⦇NTMap⦈⦇a⦈ =
(op_ntsmcf 𝔑 ∙⇩N⇩T⇩S⇩M⇩C⇩F op_ntsmcf 𝔐)⦇NTMap⦈⦇a⦈"
unfolding smc_op_simps ntsmcf_vcomp_components
by (simp add: smc_cs_simps)
qed (simp_all add: smc_op_simps smc_cs_simps ntsmcf_vcomp_components(1))
qed (auto intro: smc_cs_intros smc_op_intros)
qed
subsection‹Horizontal composition of natural transformations›
subsubsection‹Definition and elementary properties›
text‹See Chapter II-5 in \cite{mac_lane_categories_2010}.›
definition ntsmcf_hcomp :: "V ⇒ V ⇒ V" (infixl ‹∘⇩N⇩T⇩S⇩M⇩C⇩F› 55)
where "ntsmcf_hcomp 𝔐 𝔑 =
[
(
λa∈⇩∘𝔑⦇NTDGDom⦈⦇Obj⦈.
(
𝔐⦇NTCod⦈⦇ArrMap⦈⦇𝔑⦇NTMap⦈⦇a⦈⦈ ∘⇩A⇘𝔐⦇NTDGCod⦈⇙
𝔐⦇NTMap⦈⦇𝔑⦇NTDom⦈⦇ObjMap⦈⦇a⦈⦈
)
),
(𝔐⦇NTDom⦈ ∘⇩S⇩M⇩C⇩F 𝔑⦇NTDom⦈),
(𝔐⦇NTCod⦈ ∘⇩S⇩M⇩C⇩F 𝔑⦇NTCod⦈),
(𝔑⦇NTDGDom⦈),
(𝔐⦇NTDGCod⦈)
]⇩∘"
text‹Components.›
lemma ntsmcf_hcomp_components:
shows
"(𝔐 ∘⇩N⇩T⇩S⇩M⇩C⇩F 𝔑)⦇NTMap⦈ =
(
λa∈⇩∘𝔑⦇NTDGDom⦈⦇Obj⦈.
(
𝔐⦇NTCod⦈⦇ArrMap⦈⦇𝔑⦇NTMap⦈⦇a⦈⦈ ∘⇩A⇘𝔐⦇NTDGCod⦈⇙
𝔐⦇NTMap⦈⦇𝔑⦇NTDom⦈⦇ObjMap⦈⦇a⦈⦈
)
)"
and [dg_shared_cs_simps, smc_cs_simps]:
"(𝔐 ∘⇩N⇩T⇩S⇩M⇩C⇩F 𝔑)⦇NTDom⦈ = 𝔐⦇NTDom⦈ ∘⇩S⇩M⇩C⇩F 𝔑⦇NTDom⦈"
and [dg_shared_cs_simps, smc_cs_simps]:
"(𝔐 ∘⇩N⇩T⇩S⇩M⇩C⇩F 𝔑)⦇NTCod⦈ = 𝔐⦇NTCod⦈ ∘⇩S⇩M⇩C⇩F 𝔑⦇NTCod⦈"
and [dg_shared_cs_simps, smc_cs_simps]:
"(𝔐 ∘⇩N⇩T⇩S⇩M⇩C⇩F 𝔑)⦇NTDGDom⦈ = 𝔑⦇NTDGDom⦈"
and [dg_shared_cs_simps, smc_cs_simps]:
"(𝔐 ∘⇩N⇩T⇩S⇩M⇩C⇩F 𝔑)⦇NTDGCod⦈ = 𝔐⦇NTDGCod⦈"
unfolding nt_field_simps ntsmcf_hcomp_def by (auto simp: nat_omega_simps)
subsubsection‹Natural transformation map›
lemma ntsmcf_hcomp_NTMap_vsv[smc_cs_intros]: "vsv ((𝔐 ∘⇩N⇩T⇩S⇩M⇩C⇩F 𝔑)⦇NTMap⦈)"
unfolding ntsmcf_hcomp_components by auto
lemma ntsmcf_hcomp_NTMap_vdomain[smc_cs_simps]:
assumes "𝔑 : 𝔉 ↦⇩S⇩M⇩C⇩F 𝔊 : 𝔄 ↦↦⇩S⇩M⇩C⇘α⇙ 𝔅"
shows "𝒟⇩∘ ((𝔐 ∘⇩N⇩T⇩S⇩M⇩C⇩F 𝔑)⦇NTMap⦈) = 𝔄⦇Obj⦈"
proof-
interpret 𝔑: is_ntsmcf α 𝔄 𝔅 𝔉 𝔊 𝔑 by (rule assms(1))
show ?thesis unfolding ntsmcf_hcomp_components by (simp add: smc_cs_simps)
qed
lemma ntsmcf_hcomp_NTMap_app[smc_cs_simps]:
assumes "𝔐 : 𝔉' ↦⇩S⇩M⇩C⇩F 𝔊' : 𝔅 ↦↦⇩S⇩M⇩C⇘α⇙ ℭ"
and "𝔑 : 𝔉 ↦⇩S⇩M⇩C⇩F 𝔊 : 𝔄 ↦↦⇩S⇩M⇩C⇘α⇙ 𝔅"
and "a ∈⇩∘ 𝔄⦇Obj⦈"
shows "(𝔐 ∘⇩N⇩T⇩S⇩M⇩C⇩F 𝔑)⦇NTMap⦈⦇a⦈ =
𝔊'⦇ArrMap⦈⦇𝔑⦇NTMap⦈⦇a⦈⦈ ∘⇩A⇘ℭ⇙ 𝔐⦇NTMap⦈⦇𝔉⦇ObjMap⦈⦇a⦈⦈"
proof-
interpret 𝔐: is_ntsmcf α 𝔅 ℭ 𝔉' 𝔊' 𝔐 by (rule assms(1))
interpret 𝔑: is_ntsmcf α 𝔄 𝔅 𝔉 𝔊 𝔑 by (rule assms(2))
from assms(3) show ?thesis
unfolding ntsmcf_hcomp_components by (simp add: smc_cs_simps)
qed
lemma ntsmcf_hcomp_NTMap_vrange:
assumes "𝔐 : 𝔉' ↦⇩S⇩M⇩C⇩F 𝔊' : 𝔅 ↦↦⇩S⇩M⇩C⇘α⇙ ℭ"
and "𝔑 : 𝔉 ↦⇩S⇩M⇩C⇩F 𝔊 : 𝔄 ↦↦⇩S⇩M⇩C⇘α⇙ 𝔅"
shows "ℛ⇩∘ ((𝔐 ∘⇩N⇩T⇩S⇩M⇩C⇩F 𝔑)⦇NTMap⦈) ⊆⇩∘ ℭ⦇Arr⦈"
proof
interpret 𝔐: is_ntsmcf α 𝔅 ℭ 𝔉' 𝔊' 𝔐 by (rule assms(1))
interpret 𝔑: is_ntsmcf α 𝔄 𝔅 𝔉 𝔊 𝔑 by (rule assms(2))
fix f assume "f ∈⇩∘ ℛ⇩∘ ((𝔐 ∘⇩N⇩T⇩S⇩M⇩C⇩F 𝔑)⦇NTMap⦈)"
with ntsmcf_hcomp_NTMap_vdomain obtain a
where a: "a ∈⇩∘ 𝔄⦇Obj⦈" and f_def: "f = (𝔐 ∘⇩N⇩T⇩S⇩M⇩C⇩F 𝔑)⦇NTMap⦈⦇a⦈"
unfolding ntsmcf_hcomp_components by (force simp: smc_cs_simps)
have 𝔉a: "𝔉⦇ObjMap⦈⦇a⦈ ∈⇩∘ 𝔅⦇Obj⦈"
by (simp add: 𝔑.NTDom.smcf_ObjMap_app_in_HomCod_Obj a)
from 𝔑.ntsmcf_NTMap_is_arr[OF a] have "𝔊'⦇ArrMap⦈⦇𝔑⦇NTMap⦈⦇a⦈⦈ :
𝔊'⦇ObjMap⦈⦇𝔉⦇ObjMap⦈⦇a⦈⦈ ↦⇘ℭ⇙ 𝔊'⦇ObjMap⦈⦇𝔊⦇ObjMap⦈⦇a⦈⦈"
by (force intro: smc_cs_intros)
then have "𝔊'⦇ArrMap⦈⦇𝔑⦇NTMap⦈⦇a⦈⦈ ∘⇩A⇘ℭ⇙ 𝔐⦇NTMap⦈⦇𝔉⦇ObjMap⦈⦇a⦈⦈ ∈⇩∘ ℭ⦇Arr⦈"
by
(
meson
𝔐.ntsmcf_NTMap_is_arr[OF 𝔉a]
𝔐.NTDom.HomCod.smc_is_arrE
𝔐.NTDom.HomCod.smc_Comp_is_arr
)
with a show "f ∈⇩∘ ℭ⦇Arr⦈"
unfolding f_def ntsmcf_hcomp_components by (simp add: smc_cs_simps)
qed
subsubsection‹Further properties›
lemma ntsmcf_hcomp_composable_commute:
assumes "𝔐 : 𝔉' ↦⇩S⇩M⇩C⇩F 𝔊' : 𝔅 ↦↦⇩S⇩M⇩C⇘α⇙ ℭ"
and "𝔑 : 𝔉 ↦⇩S⇩M⇩C⇩F 𝔊 : 𝔄 ↦↦⇩S⇩M⇩C⇘α⇙ 𝔅"
and "f : a ↦⇘𝔄⇙ b"
shows
"(𝔐 ∘⇩N⇩T⇩S⇩M⇩C⇩F 𝔑)⦇NTMap⦈⦇b⦈ ∘⇩A⇘ℭ⇙ (𝔉' ∘⇩S⇩M⇩C⇩F 𝔉)⦇ArrMap⦈⦇f⦈ =
(𝔊' ∘⇩S⇩M⇩C⇩F 𝔊)⦇ArrMap⦈⦇f⦈ ∘⇩A⇘ℭ⇙ (𝔐 ∘⇩N⇩T⇩S⇩M⇩C⇩F 𝔑)⦇NTMap⦈⦇a⦈"
proof-
interpret 𝔐: is_ntsmcf α 𝔅 ℭ 𝔉' 𝔊' 𝔐 by (rule assms(1))
interpret 𝔑: is_ntsmcf α 𝔄 𝔅 𝔉 𝔊 𝔑 by (rule assms(2))
from assms(3) have [simp]: "b ∈⇩∘ 𝔄⦇Obj⦈" and a: "a ∈⇩∘ 𝔄⦇Obj⦈" by auto
from 𝔐.is_ntsmcf_axioms 𝔑.is_ntsmcf_axioms have 𝔐𝔑b:
"(𝔐 ∘⇩N⇩T⇩S⇩M⇩C⇩F 𝔑)⦇NTMap⦈⦇b⦈ =
(𝔊'⦇ArrMap⦈⦇𝔑⦇NTMap⦈⦇b⦈⦈) ∘⇩A⇘ℭ⇙ (𝔐⦇NTMap⦈⦇𝔉⦇ObjMap⦈⦇b⦈⦈)"
by (auto simp: smc_cs_simps)
let ?𝔊'𝔉f = ‹𝔊'⦇ArrMap⦈⦇𝔉⦇ArrMap⦈⦇f⦈⦈›
from a 𝔐.is_ntsmcf_axioms 𝔑.is_ntsmcf_axioms have 𝔐𝔑a:
"(𝔐 ∘⇩N⇩T⇩S⇩M⇩C⇩F 𝔑)⦇NTMap⦈⦇a⦈ =
𝔊'⦇ArrMap⦈⦇𝔑⦇NTMap⦈⦇a⦈⦈ ∘⇩A⇘ℭ⇙ 𝔐⦇NTMap⦈⦇𝔉⦇ObjMap⦈⦇a⦈⦈"
by (cs_concl cs_simp: smc_cs_simps)+
note 𝔐.NTCod.smcf_ArrMap_Comp[smc_cs_simps del]
from assms show ?thesis
unfolding 𝔐𝔑b 𝔐𝔑a
by (intro 𝔐.NTDom.HomCod.smc_pattern_rectangle_left)
(
cs_concl
cs_simp: smc_cs_simps is_semifunctor.smcf_ArrMap_Comp[symmetric]
cs_intro: smc_cs_intros
)+
qed
lemma ntsmcf_hcomp_is_ntsmcf:
assumes "𝔐 : 𝔉' ↦⇩S⇩M⇩C⇩F 𝔊' : 𝔅 ↦↦⇩S⇩M⇩C⇘α⇙ ℭ"
and "𝔑 : 𝔉 ↦⇩S⇩M⇩C⇩F 𝔊 : 𝔄 ↦↦⇩S⇩M⇩C⇘α⇙ 𝔅"
shows "𝔐 ∘⇩N⇩T⇩S⇩M⇩C⇩F 𝔑 : 𝔉' ∘⇩S⇩M⇩C⇩F 𝔉 ↦⇩S⇩M⇩C⇩F 𝔊' ∘⇩S⇩M⇩C⇩F 𝔊 : 𝔄 ↦↦⇩S⇩M⇩C⇘α⇙ ℭ"
proof-
interpret 𝔐: is_ntsmcf α 𝔅 ℭ 𝔉' 𝔊' 𝔐 by (rule assms(1))
interpret 𝔑: is_ntsmcf α 𝔄 𝔅 𝔉 𝔊 𝔑 by (rule assms(2))
show ?thesis
proof(intro is_ntsmcfI', unfold ntsmcf_hcomp_components(3,4))
show "vfsequence (𝔐 ∘⇩N⇩T⇩S⇩M⇩C⇩F 𝔑)" unfolding ntsmcf_hcomp_def by auto
show "vcard (𝔐 ∘⇩N⇩T⇩S⇩M⇩C⇩F 𝔑) = 5⇩ℕ"
unfolding ntsmcf_hcomp_def by (simp add: nat_omega_simps)
from assms show "(𝔐 ∘⇩N⇩T⇩S⇩M⇩C⇩F 𝔑)⦇NTMap⦈⦇a⦈ :
(𝔉' ∘⇩S⇩M⇩C⇩F 𝔉)⦇ObjMap⦈⦇a⦈ ↦⇘ℭ⇙ (𝔊' ∘⇩S⇩M⇩C⇩F 𝔊)⦇ObjMap⦈⦇a⦈"
if "a ∈⇩∘ 𝔄⦇Obj⦈" for a
using that by (cs_concl cs_simp: smc_cs_simps cs_intro: smc_cs_intros)
fix f a b assume "f : a ↦⇘𝔄⇙ b"
with ntsmcf_hcomp_composable_commute[OF assms]
show "(𝔐 ∘⇩N⇩T⇩S⇩M⇩C⇩F 𝔑)⦇NTMap⦈⦇b⦈ ∘⇩A⇘ℭ⇙ (𝔉' ∘⇩S⇩M⇩C⇩F 𝔉)⦇ArrMap⦈⦇f⦈ =
(𝔊' ∘⇩S⇩M⇩C⇩F 𝔊)⦇ArrMap⦈⦇f⦈ ∘⇩A⇘ℭ⇙ (𝔐 ∘⇩N⇩T⇩S⇩M⇩C⇩F 𝔑)⦇NTMap⦈⦇a⦈"
by auto
qed (auto simp: ntsmcf_hcomp_components(1) smc_cs_simps intro: smc_cs_intros)
qed
lemma ntsmcf_hcomp_is_ntsmcf'[smc_cs_intros]:
assumes "𝔐 : 𝔉' ↦⇩S⇩M⇩C⇩F 𝔊' : 𝔅 ↦↦⇩S⇩M⇩C⇘α⇙ ℭ"
and "𝔑 : 𝔉 ↦⇩S⇩M⇩C⇩F 𝔊 : 𝔄 ↦↦⇩S⇩M⇩C⇘α⇙ 𝔅"
and "𝔖 = 𝔉' ∘⇩S⇩M⇩C⇩F 𝔉"
and "𝔖' = 𝔊' ∘⇩S⇩M⇩C⇩F 𝔊"
shows "𝔐 ∘⇩N⇩T⇩S⇩M⇩C⇩F 𝔑 : 𝔖 ↦⇩S⇩M⇩C⇩F 𝔖' : 𝔄 ↦↦⇩S⇩M⇩C⇘α⇙ ℭ"
using assms(1,2) unfolding assms(3,4) by (rule ntsmcf_hcomp_is_ntsmcf)
lemma ntsmcf_hcomp_assoc[smc_cs_simps]:
assumes "𝔏 : 𝔉'' ↦⇩S⇩M⇩C⇩F 𝔊'' : ℭ ↦↦⇩S⇩M⇩C⇘α⇙ 𝔇"
and "𝔐 : 𝔉' ↦⇩S⇩M⇩C⇩F 𝔊' : 𝔅 ↦↦⇩S⇩M⇩C⇘α⇙ ℭ"
and "𝔑 : 𝔉 ↦⇩S⇩M⇩C⇩F 𝔊 : 𝔄 ↦↦⇩S⇩M⇩C⇘α⇙ 𝔅"
shows "(𝔏 ∘⇩N⇩T⇩S⇩M⇩C⇩F 𝔐) ∘⇩N⇩T⇩S⇩M⇩C⇩F 𝔑 = 𝔏 ∘⇩N⇩T⇩S⇩M⇩C⇩F (𝔐 ∘⇩N⇩T⇩S⇩M⇩C⇩F 𝔑)"
proof-
interpret 𝔏: is_ntsmcf α ℭ 𝔇 𝔉'' 𝔊'' 𝔏 by (rule assms(1))
interpret 𝔐: is_ntsmcf α 𝔅 ℭ 𝔉' 𝔊' 𝔐 by (rule assms(2))
interpret 𝔑: is_ntsmcf α 𝔄 𝔅 𝔉 𝔊 𝔑 by (rule assms(3))
interpret 𝔏𝔐: is_ntsmcf α 𝔅 𝔇 ‹𝔉'' ∘⇩S⇩M⇩C⇩F 𝔉'› ‹𝔊'' ∘⇩S⇩M⇩C⇩F 𝔊'› ‹𝔏 ∘⇩N⇩T⇩S⇩M⇩C⇩F 𝔐›
by (auto intro: smc_cs_intros)
interpret 𝔐𝔑: is_ntsmcf α 𝔄 ℭ ‹𝔉' ∘⇩S⇩M⇩C⇩F 𝔉› ‹𝔊' ∘⇩S⇩M⇩C⇩F 𝔊› ‹𝔐 ∘⇩N⇩T⇩S⇩M⇩C⇩F 𝔑›
by (auto intro: smc_cs_intros)
note smcf_axioms =
𝔏.NTDom.is_semifunctor_axioms
𝔏.NTCod.is_semifunctor_axioms
𝔐.NTDom.is_semifunctor_axioms
𝔐.NTCod.is_semifunctor_axioms
𝔑.NTDom.is_semifunctor_axioms
𝔑.NTCod.is_semifunctor_axioms
show ?thesis
proof(rule ntsmcf_eqI)
from assms show
"𝔏 ∘⇩N⇩T⇩S⇩M⇩C⇩F 𝔐 ∘⇩N⇩T⇩S⇩M⇩C⇩F 𝔑 :
(𝔉'' ∘⇩S⇩M⇩C⇩F 𝔉') ∘⇩S⇩M⇩C⇩F 𝔉 ↦⇩S⇩M⇩C⇩F (𝔊'' ∘⇩S⇩M⇩C⇩F 𝔊') ∘⇩S⇩M⇩C⇩F 𝔊 :
𝔄 ↦↦⇩S⇩M⇩C⇘α⇙ 𝔇"
by (auto intro: smc_cs_intros)
from 𝔏𝔐.is_ntsmcf_axioms 𝔑.is_ntsmcf_axioms have dom_lhs:
"𝒟⇩∘ ((𝔏 ∘⇩N⇩T⇩S⇩M⇩C⇩F 𝔐 ∘⇩N⇩T⇩S⇩M⇩C⇩F 𝔑)⦇NTMap⦈) = 𝔄⦇Obj⦈"
by (simp add: smc_cs_simps)
from 𝔐𝔑.is_ntsmcf_axioms 𝔏.is_ntsmcf_axioms have dom_rhs:
"𝒟⇩∘ ((𝔏 ∘⇩N⇩T⇩S⇩M⇩C⇩F (𝔐 ∘⇩N⇩T⇩S⇩M⇩C⇩F 𝔑))⦇NTMap⦈) = 𝔄⦇Obj⦈"
by (simp add: smc_cs_simps)
show "(𝔏 ∘⇩N⇩T⇩S⇩M⇩C⇩F 𝔐 ∘⇩N⇩T⇩S⇩M⇩C⇩F 𝔑)⦇NTMap⦈ = (𝔏 ∘⇩N⇩T⇩S⇩M⇩C⇩F (𝔐 ∘⇩N⇩T⇩S⇩M⇩C⇩F 𝔑))⦇NTMap⦈"
proof(rule vsv_eqI, unfold dom_lhs dom_rhs)
fix a assume "a ∈⇩∘ 𝔄⦇Obj⦈"
with assms show
"(𝔏 ∘⇩N⇩T⇩S⇩M⇩C⇩F 𝔐 ∘⇩N⇩T⇩S⇩M⇩C⇩F 𝔑)⦇NTMap⦈⦇a⦈ =
(𝔏 ∘⇩N⇩T⇩S⇩M⇩C⇩F (𝔐 ∘⇩N⇩T⇩S⇩M⇩C⇩F 𝔑))⦇NTMap⦈⦇a⦈"
by (cs_concl cs_simp: smc_cs_simps cs_intro: smc_cs_intros)
qed (simp_all add: ntsmcf_hcomp_components)
qed
(
insert smcf_axioms,
auto simp: smcf_comp_assoc intro!: smc_cs_intros
)
qed
subsubsection‹Opposite of the horizontal composition of the
natural transformation of semifunctors›
lemma op_ntsmcf_ntsmcf_hcomp[smc_op_simps]:
assumes "𝔐 : 𝔉' ↦⇩S⇩M⇩C⇩F 𝔊' : 𝔅 ↦↦⇩S⇩M⇩C⇘α⇙ ℭ"
and "𝔑 : 𝔉 ↦⇩S⇩M⇩C⇩F 𝔊 : 𝔄 ↦↦⇩S⇩M⇩C⇘α⇙ 𝔅"
shows "op_ntsmcf (𝔐 ∘⇩N⇩T⇩S⇩M⇩C⇩F 𝔑) = op_ntsmcf 𝔐 ∘⇩N⇩T⇩S⇩M⇩C⇩F op_ntsmcf 𝔑"
proof-
interpret 𝔐: is_ntsmcf α 𝔅 ℭ 𝔉' 𝔊' 𝔐 by (rule assms(1))
interpret 𝔑: is_ntsmcf α 𝔄 𝔅 𝔉 𝔊 𝔑 by (rule assms(2))
have op_𝔐: "op_ntsmcf 𝔐 :
op_smcf 𝔊' ↦⇩S⇩M⇩C⇩F op_smcf 𝔉' : op_smc 𝔅 ↦↦⇩S⇩M⇩C⇘α⇙ op_smc ℭ"
and op_𝔑: "op_ntsmcf 𝔑 :
op_smcf 𝔊 ↦⇩S⇩M⇩C⇩F op_smcf 𝔉 : op_smc 𝔄 ↦↦⇩S⇩M⇩C⇘α⇙ op_smc 𝔅"
by (cs_concl cs_simp: smc_op_simps cs_intro: smc_cs_intros smc_op_intros)
show ?thesis
proof(rule sym, rule ntsmcf_eqI, unfold smc_op_simps slicing_simps)
show
"op_ntsmcf 𝔐 ∘⇩N⇩T⇩S⇩M⇩C⇩F op_ntsmcf 𝔑 :
op_smcf 𝔊' ∘⇩S⇩M⇩C⇩F op_smcf 𝔊 ↦⇩S⇩M⇩C⇩F op_smcf 𝔉' ∘⇩S⇩M⇩C⇩F op_smcf 𝔉 :
op_smc 𝔄 ↦↦⇩S⇩M⇩C⇘α⇙ op_smc ℭ"
by (cs_concl cs_simp: smc_op_simps cs_intro: smc_cs_intros smc_op_intros)
show "op_ntsmcf (𝔐 ∘⇩N⇩T⇩S⇩M⇩C⇩F 𝔑) :
op_smcf 𝔊' ∘⇩S⇩M⇩C⇩F op_smcf 𝔊 ↦⇩S⇩M⇩C⇩F op_smcf 𝔉' ∘⇩S⇩M⇩C⇩F op_smcf 𝔉 :
op_smc 𝔄 ↦↦⇩S⇩M⇩C⇘α⇙ op_smc ℭ"
by (cs_concl cs_simp: smc_op_simps cs_intro: smc_cs_intros smc_op_intros)
show "(op_ntsmcf 𝔐 ∘⇩N⇩T⇩S⇩M⇩C⇩F op_ntsmcf 𝔑)⦇NTMap⦈ = (𝔐 ∘⇩N⇩T⇩S⇩M⇩C⇩F 𝔑)⦇NTMap⦈"
proof
(
rule vsv_eqI,
unfold
ntsmcf_hcomp_NTMap_vdomain[OF assms(2)]
ntsmcf_hcomp_NTMap_vdomain[OF op_𝔑]
smc_op_simps
)
fix a assume "a ∈⇩∘ 𝔄⦇Obj⦈"
with assms show
"(op_ntsmcf 𝔐 ∘⇩N⇩T⇩S⇩M⇩C⇩F op_ntsmcf 𝔑)⦇NTMap⦈⦇a⦈ = (𝔐 ∘⇩N⇩T⇩S⇩M⇩C⇩F 𝔑)⦇NTMap⦈⦇a⦈"
by
(
cs_concl
cs_simp: smc_cs_simps smc_op_simps
cs_intro: smc_cs_intros smc_op_intros
)
qed (auto simp: ntsmcf_hcomp_components)
qed simp_all
qed
subsection‹Interchange law›
lemma ntsmcf_comp_interchange_law:
assumes "𝔐 : 𝔊 ↦⇩S⇩M⇩C⇩F ℌ : 𝔄 ↦↦⇩S⇩M⇩C⇘α⇙ 𝔅"
and "𝔑 : 𝔉 ↦⇩S⇩M⇩C⇩F 𝔊 : 𝔄 ↦↦⇩S⇩M⇩C⇘α⇙ 𝔅"
and "𝔐' : 𝔊' ↦⇩S⇩M⇩C⇩F ℌ' : 𝔅 ↦↦⇩S⇩M⇩C⇘α⇙ ℭ"
and "𝔑' : 𝔉' ↦⇩S⇩M⇩C⇩F 𝔊' : 𝔅 ↦↦⇩S⇩M⇩C⇘α⇙ ℭ"
shows
"((𝔐' ∙⇩N⇩T⇩S⇩M⇩C⇩F 𝔑') ∘⇩N⇩T⇩S⇩M⇩C⇩F (𝔐 ∙⇩N⇩T⇩S⇩M⇩C⇩F 𝔑)) =
(𝔐' ∘⇩N⇩T⇩S⇩M⇩C⇩F 𝔐) ∙⇩N⇩T⇩S⇩M⇩C⇩F (𝔑' ∘⇩N⇩T⇩S⇩M⇩C⇩F 𝔑)"
proof-
interpret 𝔐: is_ntsmcf α 𝔄 𝔅 𝔊 ℌ 𝔐 by (rule assms(1))
interpret 𝔑: is_ntsmcf α 𝔄 𝔅 𝔉 𝔊 𝔑 by (rule assms(2))
interpret 𝔐': is_ntsmcf α 𝔅 ℭ 𝔊' ℌ' 𝔐' by (rule assms(3))
interpret 𝔑': is_ntsmcf α 𝔅 ℭ 𝔉' 𝔊' 𝔑' by (rule assms(4))
interpret 𝔑'𝔑:
is_ntsmcf α 𝔄 ℭ ‹𝔉' ∘⇩S⇩M⇩C⇩F 𝔉› ‹𝔊' ∘⇩S⇩M⇩C⇩F 𝔊› ‹𝔑' ∘⇩N⇩T⇩S⇩M⇩C⇩F 𝔑›
by (auto intro: smc_cs_intros)
interpret 𝔐𝔑: is_ntsmcf α 𝔄 𝔅 𝔉 ℌ ‹𝔐 ∙⇩N⇩T⇩S⇩M⇩C⇩F 𝔑›
by (auto intro: smc_cs_intros)
show ?thesis
proof(rule ntsmcf_eqI[of α])
show
"(𝔐' ∙⇩N⇩T⇩S⇩M⇩C⇩F 𝔑' ∘⇩N⇩T⇩S⇩M⇩C⇩F (𝔐 ∙⇩N⇩T⇩S⇩M⇩C⇩F 𝔑))⦇NTMap⦈ =
(𝔐' ∘⇩N⇩T⇩S⇩M⇩C⇩F 𝔐 ∙⇩N⇩T⇩S⇩M⇩C⇩F (𝔑' ∘⇩N⇩T⇩S⇩M⇩C⇩F 𝔑))⦇NTMap⦈"
proof
(
rule vsv_eqI,
unfold
ntsmcf_vcomp_NTMap_vdomain[OF 𝔑'𝔑.is_ntsmcf_axioms]
ntsmcf_hcomp_NTMap_vdomain[OF 𝔐𝔑.is_ntsmcf_axioms]
)
fix a assume "a ∈⇩∘ 𝔄⦇Obj⦈"
with assms show
"(𝔐' ∙⇩N⇩T⇩S⇩M⇩C⇩F 𝔑' ∘⇩N⇩T⇩S⇩M⇩C⇩F (𝔐 ∙⇩N⇩T⇩S⇩M⇩C⇩F 𝔑))⦇NTMap⦈⦇a⦈ =
((𝔐' ∘⇩N⇩T⇩S⇩M⇩C⇩F 𝔐) ∙⇩N⇩T⇩S⇩M⇩C⇩F (𝔑' ∘⇩N⇩T⇩S⇩M⇩C⇩F 𝔑))⦇NTMap⦈⦇a⦈"
by
(
cs_concl
cs_simp: smc_cs_simps is_ntsmcf.ntsmcf_Comp_commute'
cs_intro: smc_cs_intros
)
qed (auto intro: smc_cs_intros)
qed (auto intro: smc_cs_intros)
qed
subsection‹
Composition of a natural transformation of semifunctors and a semifunctor
›
subsubsection‹Definition and elementary properties›
abbreviation (input) ntsmcf_smcf_comp :: "V ⇒ V ⇒ V" (infixl "∘⇩N⇩T⇩S⇩M⇩C⇩F⇩-⇩S⇩M⇩C⇩F" 55)
where "ntsmcf_smcf_comp ≡ tdghm_dghm_comp"
text‹Slicing.›
lemma ntsmcf_tdghm_ntsmcf_smcf_comp[slicing_commute]:
"ntsmcf_tdghm 𝔑 ∘⇩T⇩D⇩G⇩H⇩M⇩-⇩D⇩G⇩H⇩M smcf_dghm ℌ = ntsmcf_tdghm (𝔑 ∘⇩N⇩T⇩S⇩M⇩C⇩F⇩-⇩S⇩M⇩C⇩F ℌ)"
unfolding
tdghm_dghm_comp_def
dghm_comp_def
ntsmcf_tdghm_def
smcf_dghm_def
smc_dg_def
dg_field_simps
dghm_field_simps
nt_field_simps
by (simp add: nat_omega_simps)
subsubsection‹Natural transformation map›
mk_VLambda (in is_semifunctor)
tdghm_dghm_comp_components(1)[where ℌ=𝔉, unfolded smcf_HomDom]
|vdomain ntsmcf_smcf_comp_NTMap_vdomain[smc_cs_simps]|
|app ntsmcf_smcf_comp_NTMap_app[smc_cs_simps]|
lemmas [smc_cs_simps] =
is_semifunctor.ntsmcf_smcf_comp_NTMap_vdomain
is_semifunctor.ntsmcf_smcf_comp_NTMap_app
lemma ntsmcf_smcf_comp_NTMap_vrange:
assumes "𝔑 : 𝔉 ↦⇩S⇩M⇩C⇩F 𝔊 : 𝔅 ↦↦⇩S⇩M⇩C⇘α⇙ ℭ" and "ℌ : 𝔄 ↦↦⇩S⇩M⇩C⇘α⇙ 𝔅"
shows "ℛ⇩∘ ((𝔑 ∘⇩N⇩T⇩S⇩M⇩C⇩F⇩-⇩S⇩M⇩C⇩F ℌ)⦇NTMap⦈) ⊆⇩∘ ℭ⦇Arr⦈"
proof-
interpret 𝔑: is_ntsmcf α 𝔅 ℭ 𝔉 𝔊 𝔑 by (rule assms(1))
interpret ℌ: is_semifunctor α 𝔄 𝔅 ℌ by (rule assms(2))
show ?thesis
unfolding tdghm_dghm_comp_components
by (auto simp: smc_cs_simps intro: smc_cs_intros)
qed
subsubsection‹
Opposite of the composition of a natural transformation of
semifunctors and a semifunctor
›
lemma op_ntsmcf_ntsmcf_smcf_comp[smc_op_simps]:
"op_ntsmcf (𝔑 ∘⇩N⇩T⇩S⇩M⇩C⇩F⇩-⇩S⇩M⇩C⇩F ℌ) = op_ntsmcf 𝔑 ∘⇩N⇩T⇩S⇩M⇩C⇩F⇩-⇩S⇩M⇩C⇩F op_smcf ℌ"
unfolding
tdghm_dghm_comp_def
dghm_comp_def
op_ntsmcf_def
op_smcf_def
op_smc_def
dg_field_simps
dghm_field_simps
nt_field_simps
by (simp add: nat_omega_simps)
subsubsection‹
Composition of a natural transformation of semifunctors and a
semifunctors is a natural transformation of semifunctors
›
lemma ntsmcf_smcf_comp_is_ntsmcf[intro]:
assumes "𝔑 : 𝔉 ↦⇩S⇩M⇩C⇩F 𝔊 : 𝔅 ↦↦⇩S⇩M⇩C⇘α⇙ ℭ" and "ℌ : 𝔄 ↦↦⇩S⇩M⇩C⇘α⇙ 𝔅"
shows "𝔑 ∘⇩N⇩T⇩S⇩M⇩C⇩F⇩-⇩S⇩M⇩C⇩F ℌ : 𝔉 ∘⇩S⇩M⇩C⇩F ℌ ↦⇩S⇩M⇩C⇩F 𝔊 ∘⇩S⇩M⇩C⇩F ℌ : 𝔄 ↦↦⇩S⇩M⇩C⇘α⇙ ℭ"
proof-
interpret 𝔑: is_ntsmcf α 𝔅 ℭ 𝔉 𝔊 𝔑 by (rule assms(1))
interpret ℌ: is_semifunctor α 𝔄 𝔅 ℌ by (rule assms(2))
show ?thesis
proof(rule is_ntsmcfI)
show "vfsequence (𝔑 ∘⇩N⇩T⇩S⇩M⇩C⇩F⇩-⇩S⇩M⇩C⇩F ℌ)"
unfolding tdghm_dghm_comp_def by (simp add: nat_omega_simps)
from assms show "𝔉 ∘⇩S⇩M⇩C⇩F ℌ : 𝔄 ↦↦⇩S⇩M⇩C⇘α⇙ ℭ"
by (cs_concl cs_intro: smc_cs_intros)
from assms show "𝔊 ∘⇩S⇩M⇩C⇩F ℌ : 𝔄 ↦↦⇩S⇩M⇩C⇘α⇙ ℭ"
by (cs_concl cs_intro: smc_cs_intros)
show "vcard (𝔑 ∘⇩N⇩T⇩S⇩M⇩C⇩F⇩-⇩S⇩M⇩C⇩F ℌ) = 5⇩ℕ"
unfolding tdghm_dghm_comp_def by (simp add: nat_omega_simps)
from assms show
"ntsmcf_tdghm (𝔑 ∘⇩N⇩T⇩S⇩M⇩C⇩F⇩-⇩S⇩M⇩C⇩F ℌ) :
smcf_dghm (𝔉 ∘⇩S⇩M⇩C⇩F ℌ) ↦⇩D⇩G⇩H⇩M smcf_dghm (𝔊 ∘⇩S⇩M⇩C⇩F ℌ) :
smc_dg 𝔄 ↦↦⇩D⇩G⇘α⇙ smc_dg ℭ"
by
(
cs_concl
cs_simp: slicing_commute[symmetric]
cs_intro: slicing_intros dg_cs_intros
)
show
"(𝔑 ∘⇩N⇩T⇩S⇩M⇩C⇩F⇩-⇩S⇩M⇩C⇩F ℌ)⦇NTMap⦈⦇b⦈ ∘⇩A⇘ℭ⇙ (𝔉 ∘⇩S⇩M⇩C⇩F ℌ)⦇ArrMap⦈⦇f⦈ =
(𝔊 ∘⇩S⇩M⇩C⇩F ℌ)⦇ArrMap⦈⦇f⦈ ∘⇩A⇘ℭ⇙ (𝔑 ∘⇩N⇩T⇩S⇩M⇩C⇩F⇩-⇩S⇩M⇩C⇩F ℌ)⦇NTMap⦈⦇a⦈"
if "f : a ↦⇘𝔄⇙ b" for a b f
using that by (cs_concl cs_simp: smc_cs_simps cs_intro: smc_cs_intros)
qed (auto simp: smc_cs_simps)
qed
lemma ntsmcf_smcf_comp_is_semifunctor'[smc_cs_intros]:
assumes "𝔑 : 𝔉 ↦⇩S⇩M⇩C⇩F 𝔊 : 𝔅 ↦↦⇩S⇩M⇩C⇘α⇙ ℭ"
and "ℌ : 𝔄 ↦↦⇩S⇩M⇩C⇘α⇙ 𝔅"
and "𝔉' = 𝔉 ∘⇩S⇩M⇩C⇩F ℌ"
and "𝔊' = 𝔊 ∘⇩S⇩M⇩C⇩F ℌ"
shows "𝔑 ∘⇩N⇩T⇩S⇩M⇩C⇩F⇩-⇩S⇩M⇩C⇩F ℌ : 𝔉' ↦⇩S⇩M⇩C⇩F 𝔊' : 𝔄 ↦↦⇩S⇩M⇩C⇘α⇙ ℭ"
using assms(1,2) unfolding assms(3,4) ..
subsubsection‹Further properties›
lemma ntsmcf_smcf_comp_ntsmcf_smcf_comp_assoc:
assumes "𝔑 : ℌ ↦⇩S⇩M⇩C⇩F ℌ' : ℭ ↦↦⇩S⇩M⇩C⇘α⇙ 𝔇"
and "𝔊 : 𝔅 ↦↦⇩S⇩M⇩C⇘α⇙ ℭ"
and "𝔉 : 𝔄 ↦↦⇩S⇩M⇩C⇘α⇙ 𝔅"
shows "(𝔑 ∘⇩N⇩T⇩S⇩M⇩C⇩F⇩-⇩S⇩M⇩C⇩F 𝔊) ∘⇩N⇩T⇩S⇩M⇩C⇩F⇩-⇩S⇩M⇩C⇩F 𝔉 = 𝔑 ∘⇩N⇩T⇩S⇩M⇩C⇩F⇩-⇩S⇩M⇩C⇩F (𝔊 ∘⇩S⇩M⇩C⇩F 𝔉)"
proof-
interpret 𝔑: is_ntsmcf α ℭ 𝔇 ℌ ℌ' 𝔑 by (rule assms(1))
interpret 𝔊: is_semifunctor α 𝔅 ℭ 𝔊 by (rule assms(2))
interpret 𝔉: is_semifunctor α 𝔄 𝔅 𝔉 by (rule assms(3))
show ?thesis
proof(rule ntsmcf_tdghm_eqI)
from assms show
"(𝔑 ∘⇩N⇩T⇩S⇩M⇩C⇩F⇩-⇩S⇩M⇩C⇩F 𝔊) ∘⇩N⇩T⇩S⇩M⇩C⇩F⇩-⇩S⇩M⇩C⇩F 𝔉 :
ℌ ∘⇩S⇩M⇩C⇩F 𝔊 ∘⇩S⇩M⇩C⇩F 𝔉 ↦⇩S⇩M⇩C⇩F ℌ' ∘⇩S⇩M⇩C⇩F 𝔊 ∘⇩S⇩M⇩C⇩F 𝔉 :
𝔄 ↦↦⇩S⇩M⇩C⇘α⇙ 𝔇"
by (cs_concl cs_simp: smc_cs_simps cs_intro: smc_cs_intros)
show "𝔑 ∘⇩N⇩T⇩S⇩M⇩C⇩F⇩-⇩S⇩M⇩C⇩F (𝔊 ∘⇩S⇩M⇩C⇩F 𝔉) :
ℌ ∘⇩S⇩M⇩C⇩F 𝔊 ∘⇩S⇩M⇩C⇩F 𝔉 ↦⇩S⇩M⇩C⇩F ℌ' ∘⇩S⇩M⇩C⇩F 𝔊 ∘⇩S⇩M⇩C⇩F 𝔉 :
𝔄 ↦↦⇩S⇩M⇩C⇘α⇙ 𝔇"
by (cs_concl cs_simp: smc_cs_simps cs_intro: smc_cs_intros)
from assms show
"ntsmcf_tdghm ((𝔑 ∘⇩N⇩T⇩S⇩M⇩C⇩F⇩-⇩S⇩M⇩C⇩F 𝔊) ∘⇩N⇩T⇩S⇩M⇩C⇩F⇩-⇩S⇩M⇩C⇩F 𝔉) =
ntsmcf_tdghm (𝔑 ∘⇩N⇩T⇩S⇩M⇩C⇩F⇩-⇩S⇩M⇩C⇩F (𝔊 ∘⇩S⇩M⇩C⇩F 𝔉))"
by
(
cs_concl
cs_simp: slicing_commute[symmetric]
cs_intro: slicing_intros tdghm_dghm_comp_tdghm_dghm_comp_assoc
)
qed simp_all
qed
lemma (in is_ntsmcf) ntsmcf_ntsmcf_smcf_comp_smcf_id[smc_cs_simps]:
"𝔑 ∘⇩N⇩T⇩S⇩M⇩C⇩F⇩-⇩S⇩M⇩C⇩F smcf_id 𝔄 = 𝔑"
proof(rule ntsmcf_tdghm_eqI)
show "𝔑 ∘⇩N⇩T⇩S⇩M⇩C⇩F⇩-⇩S⇩M⇩C⇩F smcf_id 𝔄 : 𝔉 ↦⇩S⇩M⇩C⇩F 𝔊 : 𝔄 ↦↦⇩S⇩M⇩C⇘α⇙ 𝔅"
by (cs_concl cs_simp: smc_cs_simps cs_intro: smc_cs_intros)
show "𝔑 : 𝔉 ↦⇩S⇩M⇩C⇩F 𝔊 : 𝔄 ↦↦⇩S⇩M⇩C⇘α⇙ 𝔅"
by (cs_concl cs_simp: smc_cs_simps cs_intro: smc_cs_intros)
show "ntsmcf_tdghm (𝔑 ∘⇩N⇩T⇩S⇩M⇩C⇩F⇩-⇩S⇩M⇩C⇩F smcf_id 𝔄) = ntsmcf_tdghm 𝔑"
by
(
cs_concl
cs_simp: slicing_simps slicing_commute[symmetric]
cs_intro: smc_cs_intros slicing_intros dg_cs_simps
)
qed simp_all
lemmas [smc_cs_simps] = is_ntsmcf.ntsmcf_ntsmcf_smcf_comp_smcf_id
lemma ntsmcf_vcomp_ntsmcf_smcf_comp[smc_cs_simps]:
assumes "𝔎 : 𝔄 ↦↦⇩S⇩M⇩C⇘α⇙ 𝔅"
and "𝔐 : 𝔊 ↦⇩S⇩M⇩C⇩F ℌ : 𝔅 ↦↦⇩S⇩M⇩C⇘α⇙ ℭ"
and "𝔑 : 𝔉 ↦⇩S⇩M⇩C⇩F 𝔊 : 𝔅 ↦↦⇩S⇩M⇩C⇘α⇙ ℭ"
shows
"(𝔐 ∘⇩N⇩T⇩S⇩M⇩C⇩F⇩-⇩S⇩M⇩C⇩F 𝔎) ∙⇩N⇩T⇩S⇩M⇩C⇩F (𝔑 ∘⇩N⇩T⇩S⇩M⇩C⇩F⇩-⇩S⇩M⇩C⇩F 𝔎) =
(𝔐 ∙⇩N⇩T⇩S⇩M⇩C⇩F 𝔑) ∘⇩N⇩T⇩S⇩M⇩C⇩F⇩-⇩S⇩M⇩C⇩F 𝔎"
proof(rule ntsmcf_eqI)
from assms show "(𝔐 ∙⇩N⇩T⇩S⇩M⇩C⇩F 𝔑) ∘⇩N⇩T⇩S⇩M⇩C⇩F⇩-⇩S⇩M⇩C⇩F 𝔎 :
𝔉 ∘⇩S⇩M⇩C⇩F 𝔎 ↦⇩S⇩M⇩C⇩F ℌ ∘⇩S⇩M⇩C⇩F 𝔎 : 𝔄 ↦↦⇩S⇩M⇩C⇘α⇙ ℭ"
by (cs_concl cs_intro: smc_cs_intros)
from assms show "𝔐 ∘⇩N⇩T⇩S⇩M⇩C⇩F⇩-⇩S⇩M⇩C⇩F 𝔎 ∙⇩N⇩T⇩S⇩M⇩C⇩F (𝔑 ∘⇩N⇩T⇩S⇩M⇩C⇩F⇩-⇩S⇩M⇩C⇩F 𝔎) :
𝔉 ∘⇩S⇩M⇩C⇩F 𝔎 ↦⇩S⇩M⇩C⇩F ℌ ∘⇩S⇩M⇩C⇩F 𝔎 : 𝔄 ↦↦⇩S⇩M⇩C⇘α⇙ ℭ"
by (cs_concl cs_intro: smc_cs_intros)
from assms have dom_lhs:
"𝒟⇩∘ ((𝔐 ∘⇩N⇩T⇩S⇩M⇩C⇩F⇩-⇩S⇩M⇩C⇩F 𝔎 ∙⇩N⇩T⇩S⇩M⇩C⇩F (𝔑 ∘⇩N⇩T⇩S⇩M⇩C⇩F⇩-⇩S⇩M⇩C⇩F 𝔎))⦇NTMap⦈) = 𝔄⦇Obj⦈"
by (cs_concl cs_simp: smc_cs_simps cs_intro: smc_cs_intros)
from assms have dom_rhs: "𝒟⇩∘ ((𝔐 ∙⇩N⇩T⇩S⇩M⇩C⇩F 𝔑 ∘⇩N⇩T⇩S⇩M⇩C⇩F⇩-⇩S⇩M⇩C⇩F 𝔎)⦇NTMap⦈) = 𝔄⦇Obj⦈"
by (cs_concl cs_simp: smc_cs_simps cs_intro: smc_cs_intros)
show
"(𝔐 ∘⇩N⇩T⇩S⇩M⇩C⇩F⇩-⇩S⇩M⇩C⇩F 𝔎 ∙⇩N⇩T⇩S⇩M⇩C⇩F (𝔑 ∘⇩N⇩T⇩S⇩M⇩C⇩F⇩-⇩S⇩M⇩C⇩F 𝔎))⦇NTMap⦈ =
(𝔐 ∙⇩N⇩T⇩S⇩M⇩C⇩F 𝔑 ∘⇩N⇩T⇩S⇩M⇩C⇩F⇩-⇩S⇩M⇩C⇩F 𝔎)⦇NTMap⦈"
proof(rule vsv_eqI, unfold dom_lhs dom_rhs)
fix a assume "a ∈⇩∘ 𝔄⦇Obj⦈"
with assms show
"(𝔐 ∘⇩N⇩T⇩S⇩M⇩C⇩F⇩-⇩S⇩M⇩C⇩F 𝔎 ∙⇩N⇩T⇩S⇩M⇩C⇩F (𝔑 ∘⇩N⇩T⇩S⇩M⇩C⇩F⇩-⇩S⇩M⇩C⇩F 𝔎))⦇NTMap⦈⦇a⦈ =
(𝔐 ∙⇩N⇩T⇩S⇩M⇩C⇩F 𝔑 ∘⇩N⇩T⇩S⇩M⇩C⇩F⇩-⇩S⇩M⇩C⇩F 𝔎)⦇NTMap⦈⦇a⦈"
by (cs_concl cs_simp: smc_cs_simps cs_intro: smc_cs_intros)
qed (cs_concl cs_intro: smc_cs_intros)+
qed simp_all
subsection‹
Composition of a semifunctor and a natural transformation of semifunctors
›
subsubsection‹Definition and elementary properties›
abbreviation (input) smcf_ntsmcf_comp :: "V ⇒ V ⇒ V" (infixl "∘⇩S⇩M⇩C⇩F⇩-⇩N⇩T⇩S⇩M⇩C⇩F" 55)
where "smcf_ntsmcf_comp ≡ dghm_tdghm_comp"
text‹Slicing.›
lemma ntsmcf_tdghm_smcf_ntsmcf_comp[slicing_commute]:
"smcf_dghm ℌ ∘⇩D⇩G⇩H⇩M⇩-⇩T⇩D⇩G⇩H⇩M ntsmcf_tdghm 𝔑 = ntsmcf_tdghm (ℌ ∘⇩S⇩M⇩C⇩F⇩-⇩N⇩T⇩S⇩M⇩C⇩F 𝔑)"
unfolding
dghm_tdghm_comp_def
dghm_comp_def
ntsmcf_tdghm_def
smcf_dghm_def
smc_dg_def
dg_field_simps
dghm_field_simps
nt_field_simps
by (simp add: nat_omega_simps)
subsubsection‹Natural transformation map›
mk_VLambda (in is_ntsmcf)
dghm_tdghm_comp_components(1)[where 𝔑=𝔑, unfolded ntsmcf_NTDGDom]
|vdomain smcf_ntsmcf_comp_NTMap_vdomain[smc_cs_simps]|
|app smcf_ntsmcf_comp_NTMap_app[smc_cs_simps]|
lemmas [smc_cs_simps] =
is_ntsmcf.smcf_ntsmcf_comp_NTMap_vdomain
is_ntsmcf.smcf_ntsmcf_comp_NTMap_app
lemma smcf_ntsmcf_comp_NTMap_vrange:
assumes "ℌ : 𝔅 ↦↦⇩S⇩M⇩C⇘α⇙ ℭ" and "𝔑 : 𝔉 ↦⇩S⇩M⇩C⇩F 𝔊 : 𝔄 ↦↦⇩S⇩M⇩C⇘α⇙ 𝔅"
shows "ℛ⇩∘ ((ℌ ∘⇩S⇩M⇩C⇩F⇩-⇩N⇩T⇩S⇩M⇩C⇩F 𝔑)⦇NTMap⦈) ⊆⇩∘ ℭ⦇Arr⦈"
proof-
interpret ℌ: is_semifunctor α 𝔅 ℭ ℌ by (rule assms(1))
interpret 𝔑: is_ntsmcf α 𝔄 𝔅 𝔉 𝔊 𝔑 by (rule assms(2))
show ?thesis
unfolding dghm_tdghm_comp_components
by (auto simp: smc_cs_simps intro: smc_cs_intros)
qed
subsubsection‹
Opposite of the composition of a semifunctor
and a natural transformation of semifunctors
›
lemma op_ntsmcf_smcf_ntsmcf_comp[smc_op_simps]:
"op_ntsmcf (ℌ ∘⇩S⇩M⇩C⇩F⇩-⇩N⇩T⇩S⇩M⇩C⇩F 𝔑) = op_smcf ℌ ∘⇩S⇩M⇩C⇩F⇩-⇩N⇩T⇩S⇩M⇩C⇩F op_ntsmcf 𝔑"
unfolding
dghm_tdghm_comp_def
dghm_comp_def
op_ntsmcf_def
op_smcf_def
op_smc_def
dg_field_simps
dghm_field_simps
nt_field_simps
by (simp add: nat_omega_simps)
subsubsection‹
Composition of a semifunctor and a natural transformation of
semifunctors is a natural transformation of semifunctors
›
lemma smcf_ntsmcf_comp_is_ntsmcf[intro]:
assumes "ℌ : 𝔅 ↦↦⇩S⇩M⇩C⇘α⇙ ℭ" and "𝔑 : 𝔉 ↦⇩S⇩M⇩C⇩F 𝔊 : 𝔄 ↦↦⇩S⇩M⇩C⇘α⇙ 𝔅"
shows "ℌ ∘⇩S⇩M⇩C⇩F⇩-⇩N⇩T⇩S⇩M⇩C⇩F 𝔑 : ℌ ∘⇩S⇩M⇩C⇩F 𝔉 ↦⇩S⇩M⇩C⇩F ℌ ∘⇩S⇩M⇩C⇩F 𝔊 : 𝔄 ↦↦⇩S⇩M⇩C⇘α⇙ ℭ"
proof-
interpret ℌ: is_semifunctor α 𝔅 ℭ ℌ by (rule assms(1))
interpret 𝔑: is_ntsmcf α 𝔄 𝔅 𝔉 𝔊 𝔑 by (rule assms(2))
show ?thesis
proof(rule is_ntsmcfI)
show "vfsequence (ℌ ∘⇩S⇩M⇩C⇩F⇩-⇩N⇩T⇩S⇩M⇩C⇩F 𝔑)" unfolding dghm_tdghm_comp_def by simp
from assms show "ℌ ∘⇩S⇩M⇩C⇩F 𝔉 : 𝔄 ↦↦⇩S⇩M⇩C⇘α⇙ ℭ"
by (cs_concl cs_intro: smc_cs_intros)
from assms show "ℌ ∘⇩S⇩M⇩C⇩F 𝔊 : 𝔄 ↦↦⇩S⇩M⇩C⇘α⇙ ℭ"
by (cs_concl cs_intro: smc_cs_intros)
show "vcard (ℌ ∘⇩S⇩M⇩C⇩F⇩-⇩N⇩T⇩S⇩M⇩C⇩F 𝔑) = 5⇩ℕ"
unfolding dghm_tdghm_comp_def by (simp add: nat_omega_simps)
from assms show "ntsmcf_tdghm (ℌ ∘⇩S⇩M⇩C⇩F⇩-⇩N⇩T⇩S⇩M⇩C⇩F 𝔑) :
smcf_dghm (ℌ ∘⇩S⇩M⇩C⇩F 𝔉) ↦⇩D⇩G⇩H⇩M smcf_dghm (ℌ ∘⇩S⇩M⇩C⇩F 𝔊) :
smc_dg 𝔄 ↦↦⇩D⇩G⇘α⇙ smc_dg ℭ"
by
(
cs_concl
cs_simp: slicing_commute[symmetric]
cs_intro: dg_cs_intros slicing_intros
)
have [smc_cs_simps]:
"ℌ⦇ArrMap⦈⦇𝔑⦇NTMap⦈⦇b⦈⦈ ∘⇩A⇘ℭ⇙ ℌ⦇ArrMap⦈⦇𝔉⦇ArrMap⦈⦇f⦈⦈ =
ℌ⦇ArrMap⦈⦇𝔊⦇ArrMap⦈⦇f⦈⦈ ∘⇩A⇘ℭ⇙ ℌ⦇ArrMap⦈⦇𝔑⦇NTMap⦈⦇a⦈⦈"
if "f : a ↦⇘𝔄⇙ b" for a b f
using assms that
by
(
cs_concl
cs_simp:
is_ntsmcf.ntsmcf_Comp_commute
is_semifunctor.smcf_ArrMap_Comp[symmetric]
cs_intro: smc_cs_intros
)
from assms show
"(ℌ ∘⇩S⇩M⇩C⇩F⇩-⇩N⇩T⇩S⇩M⇩C⇩F 𝔑)⦇NTMap⦈⦇b⦈ ∘⇩A⇘ℭ⇙ (ℌ ∘⇩S⇩M⇩C⇩F 𝔉)⦇ArrMap⦈⦇f⦈ =
(ℌ ∘⇩S⇩M⇩C⇩F 𝔊)⦇ArrMap⦈⦇f⦈ ∘⇩A⇘ℭ⇙ (ℌ ∘⇩S⇩M⇩C⇩F⇩-⇩N⇩T⇩S⇩M⇩C⇩F 𝔑)⦇NTMap⦈⦇a⦈"
if "f : a ↦⇘𝔄⇙ b" for a b f
using assms that
by (cs_concl cs_simp: smc_cs_simps cs_intro: smc_cs_intros)
qed (auto simp: smc_cs_simps)
qed
lemma smcf_ntsmcf_comp_is_semifunctor'[smc_cs_intros]:
assumes "ℌ : 𝔅 ↦↦⇩S⇩M⇩C⇘α⇙ ℭ"
and "𝔑 : 𝔉 ↦⇩S⇩M⇩C⇩F 𝔊 : 𝔄 ↦↦⇩S⇩M⇩C⇘α⇙ 𝔅"
and "𝔉' = ℌ ∘⇩S⇩M⇩C⇩F 𝔉"
and "𝔊' = ℌ ∘⇩S⇩M⇩C⇩F 𝔊"
shows "ℌ ∘⇩S⇩M⇩C⇩F⇩-⇩N⇩T⇩S⇩M⇩C⇩F 𝔑 : 𝔉' ↦⇩S⇩M⇩C⇩F 𝔊' : 𝔄 ↦↦⇩S⇩M⇩C⇘α⇙ ℭ"
using assms(1,2) unfolding assms(3,4) ..
subsubsection‹Further properties›
lemma smcf_comp_smcf_ntsmcf_comp_assoc:
assumes "𝔑 : ℌ ↦⇩S⇩M⇩C⇩F ℌ' : 𝔄 ↦↦⇩S⇩M⇩C⇘α⇙ 𝔅"
and "𝔉 : 𝔅 ↦↦⇩S⇩M⇩C⇘α⇙ ℭ"
and "𝔊 : ℭ ↦↦⇩S⇩M⇩C⇘α⇙ 𝔇"
shows "(𝔊 ∘⇩S⇩M⇩C⇩F 𝔉) ∘⇩S⇩M⇩C⇩F⇩-⇩N⇩T⇩S⇩M⇩C⇩F 𝔑 = 𝔊 ∘⇩S⇩M⇩C⇩F⇩-⇩N⇩T⇩S⇩M⇩C⇩F (𝔉 ∘⇩S⇩M⇩C⇩F⇩-⇩N⇩T⇩S⇩M⇩C⇩F 𝔑)"
proof(rule ntsmcf_tdghm_eqI)
interpret 𝔑: is_ntsmcf α 𝔄 𝔅 ℌ ℌ' 𝔑 by (rule assms(1))
interpret 𝔉: is_semifunctor α 𝔅 ℭ 𝔉 by (rule assms(2))
interpret 𝔊: is_semifunctor α ℭ 𝔇 𝔊 by (rule assms(3))
from assms show "(𝔊 ∘⇩S⇩M⇩C⇩F 𝔉) ∘⇩S⇩M⇩C⇩F⇩-⇩N⇩T⇩S⇩M⇩C⇩F 𝔑 :
𝔊 ∘⇩S⇩M⇩C⇩F 𝔉 ∘⇩S⇩M⇩C⇩F ℌ ↦⇩S⇩M⇩C⇩F 𝔊 ∘⇩S⇩M⇩C⇩F 𝔉 ∘⇩S⇩M⇩C⇩F ℌ' : 𝔄 ↦↦⇩S⇩M⇩C⇘α⇙ 𝔇"
by (cs_concl cs_simp: smc_cs_simps cs_intro: smc_cs_intros)
from assms show "𝔊 ∘⇩S⇩M⇩C⇩F⇩-⇩N⇩T⇩S⇩M⇩C⇩F (𝔉 ∘⇩S⇩M⇩C⇩F⇩-⇩N⇩T⇩S⇩M⇩C⇩F 𝔑) :
𝔊 ∘⇩S⇩M⇩C⇩F 𝔉 ∘⇩S⇩M⇩C⇩F ℌ ↦⇩S⇩M⇩C⇩F 𝔊 ∘⇩S⇩M⇩C⇩F 𝔉 ∘⇩S⇩M⇩C⇩F ℌ' : 𝔄 ↦↦⇩S⇩M⇩C⇘α⇙ 𝔇"
by (cs_concl cs_simp: smc_cs_simps cs_intro: smc_cs_intros)
from assms show
"ntsmcf_tdghm (𝔊 ∘⇩S⇩M⇩C⇩F 𝔉 ∘⇩S⇩M⇩C⇩F⇩-⇩N⇩T⇩S⇩M⇩C⇩F 𝔑) =
ntsmcf_tdghm (𝔊 ∘⇩S⇩M⇩C⇩F⇩-⇩N⇩T⇩S⇩M⇩C⇩F (𝔉 ∘⇩S⇩M⇩C⇩F⇩-⇩N⇩T⇩S⇩M⇩C⇩F 𝔑))"
by
(
cs_concl
cs_simp: slicing_commute[symmetric]
cs_intro: slicing_intros dghm_comp_dghm_tdghm_comp_assoc
)
qed simp_all
lemma (in is_ntsmcf) ntsmcf_smcf_ntsmcf_comp_smcf_id[smc_cs_simps]:
"smcf_id 𝔅 ∘⇩S⇩M⇩C⇩F⇩-⇩N⇩T⇩S⇩M⇩C⇩F 𝔑 = 𝔑"
proof(rule ntsmcf_tdghm_eqI)
show "smcf_id 𝔅 ∘⇩S⇩M⇩C⇩F⇩-⇩N⇩T⇩S⇩M⇩C⇩F 𝔑 : 𝔉 ↦⇩S⇩M⇩C⇩F 𝔊 : 𝔄 ↦↦⇩S⇩M⇩C⇘α⇙ 𝔅"
by (cs_concl cs_simp: smc_cs_simps cs_intro: smc_cs_intros)
show "𝔑 : 𝔉 ↦⇩S⇩M⇩C⇩F 𝔊 : 𝔄 ↦↦⇩S⇩M⇩C⇘α⇙ 𝔅"
by (cs_concl cs_simp: smc_cs_simps cs_intro: smc_cs_intros)
show "ntsmcf_tdghm (dghm_id 𝔅 ∘⇩D⇩G⇩H⇩M⇩-⇩T⇩D⇩G⇩H⇩M 𝔑) = ntsmcf_tdghm 𝔑"
by
(
cs_concl
cs_simp: slicing_simps slicing_commute[symmetric]
cs_intro: smc_cs_intros slicing_intros dg_cs_simps
)
qed simp_all
lemmas [smc_cs_simps] = is_ntsmcf.ntsmcf_smcf_ntsmcf_comp_smcf_id
lemma smcf_ntsmcf_comp_ntsmcf_smcf_comp_assoc:
assumes "𝔑 : 𝔉 ↦⇩S⇩M⇩C⇩F 𝔊 : 𝔅 ↦↦⇩S⇩M⇩C⇘α⇙ ℭ"
and "ℌ : ℭ ↦↦⇩S⇩M⇩C⇘α⇙ 𝔇"
and "𝔎 : 𝔄 ↦↦⇩S⇩M⇩C⇘α⇙ 𝔅"
shows "(ℌ ∘⇩S⇩M⇩C⇩F⇩-⇩N⇩T⇩S⇩M⇩C⇩F 𝔑) ∘⇩N⇩T⇩S⇩M⇩C⇩F⇩-⇩S⇩M⇩C⇩F 𝔎 = ℌ ∘⇩S⇩M⇩C⇩F⇩-⇩N⇩T⇩S⇩M⇩C⇩F (𝔑 ∘⇩N⇩T⇩S⇩M⇩C⇩F⇩-⇩S⇩M⇩C⇩F 𝔎)"
proof-
interpret 𝔑: is_ntsmcf α 𝔅 ℭ 𝔉 𝔊 𝔑 by (rule assms(1))
interpret ℌ: is_semifunctor α ℭ 𝔇 ℌ by (rule assms(2))
interpret 𝔎: is_semifunctor α 𝔄 𝔅 𝔎 by (rule assms(3))
show ?thesis
by (rule ntsmcf_tdghm_eqI)
(
use assms in
‹
cs_concl
cs_simp: smc_cs_simps slicing_commute[symmetric]
cs_intro:
smc_cs_intros
slicing_intros
dghm_tdghm_comp_tdghm_dghm_comp_assoc
›
)+
qed
lemma smcf_ntsmcf_comp_ntsmcf_vcomp:
assumes "𝔎 : 𝔅 ↦↦⇩S⇩M⇩C⇘α⇙ ℭ"
and "𝔐 : 𝔊 ↦⇩S⇩M⇩C⇩F ℌ : 𝔄 ↦↦⇩S⇩M⇩C⇘α⇙ 𝔅"
and "𝔑 : 𝔉 ↦⇩S⇩M⇩C⇩F 𝔊 : 𝔄 ↦↦⇩S⇩M⇩C⇘α⇙ 𝔅"
shows
"𝔎 ∘⇩S⇩M⇩C⇩F⇩-⇩N⇩T⇩S⇩M⇩C⇩F (𝔐 ∙⇩N⇩T⇩S⇩M⇩C⇩F 𝔑) =
(𝔎 ∘⇩S⇩M⇩C⇩F⇩-⇩N⇩T⇩S⇩M⇩C⇩F 𝔐) ∙⇩N⇩T⇩S⇩M⇩C⇩F (𝔎 ∘⇩S⇩M⇩C⇩F⇩-⇩N⇩T⇩S⇩M⇩C⇩F 𝔑)"
proof-
interpret 𝔎: is_semifunctor α 𝔅 ℭ 𝔎 by (rule assms(1))
interpret 𝔐: is_ntsmcf α 𝔄 𝔅 𝔊 ℌ 𝔐 by (rule assms(2))
interpret 𝔑: is_ntsmcf α 𝔄 𝔅 𝔉 𝔊 𝔑 by (rule assms(3))
show
"𝔎 ∘⇩S⇩M⇩C⇩F⇩-⇩N⇩T⇩S⇩M⇩C⇩F (𝔐 ∙⇩N⇩T⇩S⇩M⇩C⇩F 𝔑) = 𝔎 ∘⇩S⇩M⇩C⇩F⇩-⇩N⇩T⇩S⇩M⇩C⇩F 𝔐 ∙⇩N⇩T⇩S⇩M⇩C⇩F (𝔎 ∘⇩S⇩M⇩C⇩F⇩-⇩N⇩T⇩S⇩M⇩C⇩F 𝔑)"
proof(rule ntsmcf_eqI)
have dom_lhs: "𝒟⇩∘ ((𝔎 ∘⇩S⇩M⇩C⇩F⇩-⇩N⇩T⇩S⇩M⇩C⇩F (𝔐 ∙⇩N⇩T⇩S⇩M⇩C⇩F 𝔑))⦇NTMap⦈) = 𝔄⦇Obj⦈"
unfolding dghm_tdghm_comp_components smc_cs_simps by simp
have dom_rhs:
"𝒟⇩∘ ((𝔎 ∘⇩S⇩M⇩C⇩F⇩-⇩N⇩T⇩S⇩M⇩C⇩F 𝔐 ∙⇩N⇩T⇩S⇩M⇩C⇩F (𝔎 ∘⇩S⇩M⇩C⇩F⇩-⇩N⇩T⇩S⇩M⇩C⇩F 𝔑))⦇NTMap⦈) = 𝔄⦇Obj⦈"
unfolding ntsmcf_vcomp_components smc_cs_simps by simp
show
"(𝔎 ∘⇩S⇩M⇩C⇩F⇩-⇩N⇩T⇩S⇩M⇩C⇩F (𝔐 ∙⇩N⇩T⇩S⇩M⇩C⇩F 𝔑))⦇NTMap⦈ =
(𝔎 ∘⇩S⇩M⇩C⇩F⇩-⇩N⇩T⇩S⇩M⇩C⇩F 𝔐 ∙⇩N⇩T⇩S⇩M⇩C⇩F (𝔎 ∘⇩S⇩M⇩C⇩F⇩-⇩N⇩T⇩S⇩M⇩C⇩F 𝔑))⦇NTMap⦈"
proof(rule vsv_eqI, unfold dom_lhs dom_rhs smc_cs_simps)
fix a assume "a ∈⇩∘ 𝔄⦇Obj⦈"
then show
"(𝔎 ∘⇩S⇩M⇩C⇩F⇩-⇩N⇩T⇩S⇩M⇩C⇩F (𝔐 ∙⇩N⇩T⇩S⇩M⇩C⇩F 𝔑))⦇NTMap⦈⦇a⦈ =
(𝔎 ∘⇩S⇩M⇩C⇩F⇩-⇩N⇩T⇩S⇩M⇩C⇩F 𝔐 ∙⇩N⇩T⇩S⇩M⇩C⇩F (𝔎 ∘⇩S⇩M⇩C⇩F⇩-⇩N⇩T⇩S⇩M⇩C⇩F 𝔑))⦇NTMap⦈⦇a⦈"
by (cs_concl cs_simp: smc_cs_simps cs_intro: smc_cs_intros)
qed (cs_concl cs_intro: smc_cs_intros)+
qed (cs_concl cs_intro: smc_cs_intros)+
qed
text‹\newpage›
end
Theory CZH_SMC_Small_NTSMCF
section‹Smallness for natural transformations of semifunctors›
theory CZH_SMC_Small_NTSMCF
imports
CZH_DG_Small_TDGHM
CZH_SMC_Small_Semifunctor
CZH_SMC_NTSMCF
begin
subsection‹Natural transformation of semifunctors with tiny maps›
subsubsection‹Definition and elementary properties›
locale is_tm_ntsmcf = is_ntsmcf α 𝔄 𝔅 𝔉 𝔊 𝔑 for α 𝔄 𝔅 𝔉 𝔊 𝔑 +
assumes tm_ntsmcf_is_tm_tdghm[slicing_intros]: "ntsmcf_tdghm 𝔑 :
smcf_dghm 𝔉 ↦⇩D⇩G⇩H⇩M⇩.⇩t⇩m smcf_dghm 𝔊 : smc_dg 𝔄 ↦↦⇩D⇩G⇩.⇩t⇩m⇘α⇙ smc_dg 𝔅"
syntax "_is_tm_ntsmcf" :: "V ⇒ V ⇒ V ⇒ V ⇒ V ⇒ V ⇒ bool"
(‹(_ :/ _ ↦⇩S⇩M⇩C⇩F⇩.⇩t⇩m _ :/ _ ↦↦⇩S⇩M⇩C⇩.⇩t⇩mı _)› [51, 51, 51, 51, 51] 51)
translations "𝔑 : 𝔉 ↦⇩S⇩M⇩C⇩F⇩.⇩t⇩m 𝔊 : 𝔄 ↦↦⇩S⇩M⇩C⇩.⇩t⇩m⇘α⇙ 𝔅" ⇌
"CONST is_tm_ntsmcf α 𝔄 𝔅 𝔉 𝔊 𝔑"
abbreviation all_tm_ntsmcfs :: "V ⇒ V"
where "all_tm_ntsmcfs α ≡
set {𝔑. ∃𝔉 𝔊 𝔄 𝔅. 𝔑 : 𝔉 ↦⇩S⇩M⇩C⇩F⇩.⇩t⇩m 𝔊 : 𝔄 ↦↦⇩S⇩M⇩C⇩.⇩t⇩m⇘α⇙ 𝔅}"
abbreviation tm_ntsmcfs :: "V ⇒ V ⇒ V ⇒ V"
where "tm_ntsmcfs α 𝔄 𝔅 ≡
set {𝔑. ∃𝔉 𝔊. 𝔑 : 𝔉 ↦⇩S⇩M⇩C⇩F⇩.⇩t⇩m 𝔊 : 𝔄 ↦↦⇩S⇩M⇩C⇩.⇩t⇩m⇘α⇙ 𝔅}"
abbreviation these_tm_ntsmcfs :: "V ⇒ V ⇒ V ⇒ V ⇒ V ⇒ V"
where "these_tm_ntsmcfs α 𝔄 𝔅 𝔉 𝔊 ≡
set {𝔑. 𝔑 : 𝔉 ↦⇩S⇩M⇩C⇩F⇩.⇩t⇩m 𝔊 : 𝔄 ↦↦⇩S⇩M⇩C⇩.⇩t⇩m⇘α⇙ 𝔅}"
lemma (in is_tm_ntsmcf) tm_ntsmcf_is_tm_tdghm':
assumes "α' = α"
and "𝔉' = smcf_dghm 𝔉"
and "𝔊' = smcf_dghm 𝔊"
and "𝔄' = smc_dg 𝔄"
and "𝔅' = smc_dg 𝔅"
shows "ntsmcf_tdghm 𝔑 :
𝔉' ↦⇩D⇩G⇩H⇩M⇩.⇩t⇩m 𝔊' : 𝔄' ↦↦⇩D⇩G⇩.⇩t⇩m⇘α'⇙ 𝔅'"
unfolding assms by (rule tm_ntsmcf_is_tm_tdghm)
lemmas [slicing_intros] = is_tm_ntsmcf.tm_ntsmcf_is_tm_tdghm'
text‹Rules.›
lemma (in is_tm_ntsmcf) is_tm_ntsmcf_axioms'[smc_small_cs_intros]:
assumes "α' = α" and "𝔄' = 𝔄" and "𝔅' = 𝔅" and "𝔉' = 𝔉" and "𝔊' = 𝔊"
shows "𝔑 : 𝔉' ↦⇩S⇩M⇩C⇩F⇩.⇩t⇩m 𝔊' : 𝔄' ↦↦⇩S⇩M⇩C⇩.⇩t⇩m⇘α⇙ 𝔅'"
unfolding assms by (rule is_tm_ntsmcf_axioms)
mk_ide rf is_tm_ntsmcf_def[unfolded is_tm_ntsmcf_axioms_def]
|intro is_tm_ntsmcfI|
|dest is_tm_ntsmcfD[dest]|
|elim is_tm_ntsmcfE[elim]|
lemmas [smc_small_cs_intros] = is_tm_ntsmcfD(1)
text‹Slicing.›
context is_tm_ntsmcf
begin
interpretation tdghm: is_tm_tdghm
α ‹smc_dg 𝔄› ‹smc_dg 𝔅› ‹smcf_dghm 𝔉› ‹smcf_dghm 𝔊› ‹ntsmcf_tdghm 𝔑›
by (rule tm_ntsmcf_is_tm_tdghm)
lemmas_with [unfolded slicing_simps]:
tm_ntsmcf_NTMap_in_Vset = tdghm.tm_tdghm_NTMap_in_Vset
end
text‹Elementary properties.›
sublocale is_tm_ntsmcf ⊆ NTDom: is_tm_semifunctor α 𝔄 𝔅 𝔉
using tm_ntsmcf_is_tm_tdghm
by (intro is_tm_semifunctorI) (auto simp: smc_cs_intros)
sublocale is_tm_ntsmcf ⊆ NTCod: is_tm_semifunctor α 𝔄 𝔅 𝔊
using tm_ntsmcf_is_tm_tdghm
by (intro is_tm_semifunctorI) (auto simp: smc_cs_intros)
text‹Further rules.›
lemma is_tm_ntsmcfI':
assumes "𝔑 : 𝔉 ↦⇩S⇩M⇩C⇩F 𝔊 : 𝔄 ↦↦⇩S⇩M⇩C⇘α⇙ 𝔅"
and "𝔉 : 𝔄 ↦↦⇩S⇩M⇩C⇩.⇩t⇩m⇘α⇙ 𝔅"
and "𝔊 : 𝔄 ↦↦⇩S⇩M⇩C⇩.⇩t⇩m⇘α⇙ 𝔅"
shows "𝔑 : 𝔉 ↦⇩S⇩M⇩C⇩F⇩.⇩t⇩m 𝔊 : 𝔄 ↦↦⇩S⇩M⇩C⇩.⇩t⇩m⇘α⇙ 𝔅"
proof-
interpret is_ntsmcf α 𝔄 𝔅 𝔉 𝔊 𝔑 by (rule assms(1))
interpret 𝔉: is_tm_semifunctor α 𝔄 𝔅 𝔉 by (rule assms(2))
interpret 𝔊: is_tm_semifunctor α 𝔄 𝔅 𝔊 by (rule assms(3))
show ?thesis
proof(intro is_tm_ntsmcfI)
show "ntsmcf_tdghm 𝔑 :
smcf_dghm 𝔉 ↦⇩D⇩G⇩H⇩M⇩.⇩t⇩m smcf_dghm 𝔊 : smc_dg 𝔄 ↦↦⇩D⇩G⇩.⇩t⇩m⇘α⇙ smc_dg 𝔅"
by (intro is_tm_tdghmI) (auto simp: slicing_intros)
qed (auto simp: assms(2,3) vfsequence_axioms smc_cs_intros)
qed
lemma is_tm_ntsmcfD':
assumes "𝔑 : 𝔉 ↦⇩S⇩M⇩C⇩F⇩.⇩t⇩m 𝔊 : 𝔄 ↦↦⇩S⇩M⇩C⇩.⇩t⇩m⇘α⇙ 𝔅"
shows "𝔑 : 𝔉 ↦⇩S⇩M⇩C⇩F 𝔊 : 𝔄 ↦↦⇩S⇩M⇩C⇘α⇙ 𝔅"
and "𝔉 : 𝔄 ↦↦⇩S⇩M⇩C⇩.⇩t⇩m⇘α⇙ 𝔅"
and "𝔊 : 𝔄 ↦↦⇩S⇩M⇩C⇩.⇩t⇩m⇘α⇙ 𝔅"
proof-
interpret is_tm_ntsmcf α 𝔄 𝔅 𝔉 𝔊 𝔑 by (rule assms(1))
show "𝔑 : 𝔉 ↦⇩S⇩M⇩C⇩F 𝔊 : 𝔄 ↦↦⇩S⇩M⇩C⇘α⇙ 𝔅"
and "𝔉 : 𝔄 ↦↦⇩S⇩M⇩C⇩.⇩t⇩m⇘α⇙ 𝔅"
and "𝔊 : 𝔄 ↦↦⇩S⇩M⇩C⇩.⇩t⇩m⇘α⇙ 𝔅"
by (auto simp: smc_small_cs_intros)
qed
lemmas [smc_small_cs_intros] = is_tm_ntsmcfD'(2,3)
text‹Size.›
lemma small_all_tm_ntsmcfs[simp]:
"small {𝔑. ∃𝔉 𝔊 𝔄 𝔅. 𝔑 : 𝔉 ↦⇩S⇩M⇩C⇩F⇩.⇩t⇩m 𝔊 : 𝔄 ↦↦⇩S⇩M⇩C⇩.⇩t⇩m⇘α⇙ 𝔅}"
proof(rule down)
show "{𝔑. ∃𝔉 𝔊 𝔄 𝔅. 𝔑 : 𝔉 ↦⇩S⇩M⇩C⇩F⇩.⇩t⇩m 𝔊 : 𝔄 ↦↦⇩S⇩M⇩C⇩.⇩t⇩m⇘α⇙ 𝔅} ⊆
elts (set {𝔑. ∃𝔉 𝔊 𝔄 𝔅. 𝔑 : 𝔉 ↦⇩S⇩M⇩C⇩F 𝔊 : 𝔄 ↦↦⇩S⇩M⇩C⇘α⇙ 𝔅})"
proof
(
simp only: elts_of_set small_all_ntsmcfs if_True,
rule subsetI,
unfold mem_Collect_eq
)
fix 𝔑 assume "∃𝔉 𝔊 𝔄 𝔅. 𝔑 : 𝔉 ↦⇩S⇩M⇩C⇩F⇩.⇩t⇩m 𝔊 : 𝔄 ↦↦⇩S⇩M⇩C⇩.⇩t⇩m⇘α⇙ 𝔅"
then obtain 𝔉 𝔊 𝔄 𝔅 where "𝔑 : 𝔉 ↦⇩S⇩M⇩C⇩F⇩.⇩t⇩m 𝔊 : 𝔄 ↦↦⇩S⇩M⇩C⇩.⇩t⇩m⇘α⇙ 𝔅"
by clarsimp
then interpret is_tm_ntsmcf α 𝔄 𝔅 𝔉 𝔊 𝔑 .
have "𝔑 : 𝔉 ↦⇩S⇩M⇩C⇩F 𝔊 : 𝔄 ↦↦⇩S⇩M⇩C⇘α⇙ 𝔅" by (auto simp: smc_cs_intros)
then show "∃𝔉 𝔊 𝔄 𝔅. 𝔑 : 𝔉 ↦⇩S⇩M⇩C⇩F 𝔊 : 𝔄 ↦↦⇩S⇩M⇩C⇘α⇙ 𝔅" by auto
qed
qed
lemma small_tm_ntsmcfs[simp]:
"small {𝔑. ∃𝔉 𝔊. 𝔑 : 𝔉 ↦⇩S⇩M⇩C⇩F⇩.⇩t⇩m 𝔊 : 𝔄 ↦↦⇩S⇩M⇩C⇩.⇩t⇩m⇘α⇙ 𝔅}"
by
(
rule
down[
of _ ‹set {𝔑. ∃𝔉 𝔊 𝔄 𝔅. 𝔑 : 𝔉 ↦⇩S⇩M⇩C⇩F⇩.⇩t⇩m 𝔊 : 𝔄 ↦↦⇩S⇩M⇩C⇩.⇩t⇩m⇘α⇙ 𝔅}›
]
)
auto
lemma small_these_tm_ntsmcfs[simp]:
"small {𝔑. 𝔑 : 𝔉 ↦⇩S⇩M⇩C⇩F⇩.⇩t⇩m 𝔊 : 𝔄 ↦↦⇩S⇩M⇩C⇩.⇩t⇩m⇘α⇙ 𝔅}"
by
(
rule
down[
of _ ‹set {𝔑. ∃𝔉 𝔊 𝔄 𝔅. 𝔑 : 𝔉 ↦⇩S⇩M⇩C⇩F⇩.⇩t⇩m 𝔊 : 𝔄 ↦↦⇩S⇩M⇩C⇩.⇩t⇩m⇘α⇙ 𝔅}›
]
)
auto
text‹Further elementary results.›
lemma these_tm_ntsmcfs_iff:
"𝔑 ∈⇩∘ these_tm_ntsmcfs α 𝔄 𝔅 𝔉 𝔊 ⟷
𝔑 : 𝔉 ↦⇩S⇩M⇩C⇩F⇩.⇩t⇩m 𝔊 : 𝔄 ↦↦⇩S⇩M⇩C⇩.⇩t⇩m⇘α⇙ 𝔅"
by auto
subsubsection‹
Opposite natural transformation of semifunctors with tiny maps
›
lemma (in is_tm_ntsmcf) is_tm_ntsmcf_op: "op_ntsmcf 𝔑 :
op_smcf 𝔊 ↦⇩S⇩M⇩C⇩F⇩.⇩t⇩m op_smcf 𝔉 : op_smc 𝔄 ↦↦⇩S⇩M⇩C⇩.⇩t⇩m⇘α⇙ op_smc 𝔅"
by (intro is_tm_ntsmcfI')
(cs_concl cs_intro: smc_cs_intros smc_op_intros)+
lemma (in is_tm_ntsmcf) is_tm_ntsmcf_op'[smc_op_intros]:
assumes "𝔊' = op_smcf 𝔊"
and "𝔉' = op_smcf 𝔉"
and "𝔄' = op_smc 𝔄"
and "𝔅' = op_smc 𝔅"
shows "op_ntsmcf 𝔑 : 𝔊' ↦⇩S⇩M⇩C⇩F⇩.⇩t⇩m 𝔉' : 𝔄' ↦↦⇩S⇩M⇩C⇩.⇩t⇩m⇘α⇙ 𝔅'"
unfolding assms by (rule is_tm_ntsmcf_op)
lemmas is_tm_ntsmcf_op[smc_op_intros] = is_tm_ntsmcf.is_tm_ntsmcf_op'
subsubsection‹
Vertical composition of natural transformations of
semifunctors with tiny maps
›
lemma ntsmcf_vcomp_is_tm_ntsmcf[smc_small_cs_intros]:
assumes "𝔐 : 𝔊 ↦⇩S⇩M⇩C⇩F⇩.⇩t⇩m ℌ : 𝔄 ↦↦⇩S⇩M⇩C⇩.⇩t⇩m⇘α⇙ 𝔅"
and "𝔑 : 𝔉 ↦⇩S⇩M⇩C⇩F⇩.⇩t⇩m 𝔊 : 𝔄 ↦↦⇩S⇩M⇩C⇩.⇩t⇩m⇘α⇙ 𝔅"
shows "𝔐 ∙⇩N⇩T⇩S⇩M⇩C⇩F 𝔑 : 𝔉 ↦⇩S⇩M⇩C⇩F⇩.⇩t⇩m ℌ : 𝔄 ↦↦⇩S⇩M⇩C⇩.⇩t⇩m⇘α⇙ 𝔅"
proof-
interpret 𝔐: is_tm_ntsmcf α 𝔄 𝔅 𝔊 ℌ 𝔐 by (rule assms(1))
interpret 𝔑: is_tm_ntsmcf α 𝔄 𝔅 𝔉 𝔊 𝔑 by (rule assms(2))
show ?thesis
by (rule is_tm_ntsmcfI') (auto intro: smc_cs_intros smc_small_cs_intros)
qed
subsubsection‹
Composition of a natural transformation of semifunctors and a semifunctor
›
lemma ntsmcf_smcf_comp_is_tm_ntsmcf:
assumes "𝔑 : 𝔉 ↦⇩S⇩M⇩C⇩F⇩.⇩t⇩m 𝔊 : 𝔅 ↦↦⇩S⇩M⇩C⇩.⇩t⇩m⇘α⇙ ℭ" and "ℌ : 𝔄 ↦↦⇩S⇩M⇩C⇩.⇩t⇩m⇘α⇙ 𝔅"
shows "𝔑 ∘⇩N⇩T⇩S⇩M⇩C⇩F⇩-⇩S⇩M⇩C⇩F ℌ : 𝔉 ∘⇩S⇩M⇩C⇩F ℌ ↦⇩S⇩M⇩C⇩F⇩.⇩t⇩m 𝔊 ∘⇩S⇩M⇩C⇩F ℌ : 𝔄 ↦↦⇩S⇩M⇩C⇩.⇩t⇩m⇘α⇙ ℭ"
proof-
interpret 𝔑: is_tm_ntsmcf α 𝔅 ℭ 𝔉 𝔊 𝔑 by (rule assms(1))
interpret ℌ: is_tm_semifunctor α 𝔄 𝔅 ℌ by (rule assms(2))
from assms show ?thesis
by (intro is_tm_ntsmcfI)
(
cs_concl
cs_simp: slicing_commute[symmetric]
cs_intro: smc_cs_intros dg_small_cs_intros slicing_intros
)+
qed
lemma ntsmcf_smcf_comp_is_tm_ntsmcf'[smc_small_cs_intros]:
assumes "𝔑 : 𝔉 ↦⇩S⇩M⇩C⇩F⇩.⇩t⇩m 𝔊 : 𝔅 ↦↦⇩S⇩M⇩C⇩.⇩t⇩m⇘α⇙ ℭ"
and "ℌ : 𝔄 ↦↦⇩S⇩M⇩C⇩.⇩t⇩m⇘α⇙ 𝔅"
and "𝔉' = 𝔉 ∘⇩S⇩M⇩C⇩F ℌ"
and "𝔊' = 𝔊 ∘⇩S⇩M⇩C⇩F ℌ"
shows "𝔑 ∘⇩N⇩T⇩S⇩M⇩C⇩F⇩-⇩S⇩M⇩C⇩F ℌ : 𝔉' ↦⇩S⇩M⇩C⇩F⇩.⇩t⇩m 𝔊' : 𝔄 ↦↦⇩S⇩M⇩C⇩.⇩t⇩m⇘α⇙ ℭ"
using assms(1,2) unfolding assms(3,4) by (rule ntsmcf_smcf_comp_is_tm_ntsmcf)
subsubsection‹
Composition of a semifunctor and a natural transformation of semifunctors
›
lemma smcf_ntsmcf_comp_is_tm_ntsmcf:
assumes "ℌ : 𝔅 ↦↦⇩S⇩M⇩C⇩.⇩t⇩m⇘α⇙ ℭ" and "𝔑 : 𝔉 ↦⇩S⇩M⇩C⇩F⇩.⇩t⇩m 𝔊 : 𝔄 ↦↦⇩S⇩M⇩C⇩.⇩t⇩m⇘α⇙ 𝔅"
shows "ℌ ∘⇩S⇩M⇩C⇩F⇩-⇩N⇩T⇩S⇩M⇩C⇩F 𝔑 : ℌ ∘⇩S⇩M⇩C⇩F 𝔉 ↦⇩S⇩M⇩C⇩F⇩.⇩t⇩m ℌ ∘⇩S⇩M⇩C⇩F 𝔊 : 𝔄 ↦↦⇩S⇩M⇩C⇩.⇩t⇩m⇘α⇙ ℭ"
proof-
interpret ℌ: is_tm_semifunctor α 𝔅 ℭ ℌ by (rule assms(1))
interpret 𝔑: is_tm_ntsmcf α 𝔄 𝔅 𝔉 𝔊 𝔑 by (rule assms(2))
from assms show ?thesis
by (intro is_tm_ntsmcfI)
(
cs_concl
cs_simp: slicing_commute[symmetric]
cs_intro: smc_cs_intros dg_small_cs_intros slicing_intros
)+
qed
lemma smcf_ntsmcf_comp_is_tm_ntsmcf'[smc_small_cs_intros]:
assumes "ℌ : 𝔅 ↦↦⇩S⇩M⇩C⇩.⇩t⇩m⇘α⇙ ℭ"
and "𝔑 : 𝔉 ↦⇩S⇩M⇩C⇩F⇩.⇩t⇩m 𝔊 : 𝔄 ↦↦⇩S⇩M⇩C⇩.⇩t⇩m⇘α⇙ 𝔅"
and "𝔉' = ℌ ∘⇩S⇩M⇩C⇩F 𝔉"
and "𝔊' = ℌ ∘⇩S⇩M⇩C⇩F 𝔊"
shows "ℌ ∘⇩S⇩M⇩C⇩F⇩-⇩N⇩T⇩S⇩M⇩C⇩F 𝔑 : 𝔉' ↦⇩S⇩M⇩C⇩F⇩.⇩t⇩m 𝔊' : 𝔄 ↦↦⇩S⇩M⇩C⇩.⇩t⇩m⇘α⇙ ℭ"
using assms(1,2) unfolding assms(3,4) by (rule smcf_ntsmcf_comp_is_tm_ntsmcf)
subsection‹Tiny natural transformation of semifunctors›
subsubsection‹Definition and elementary properties›
locale is_tiny_ntsmcf = is_ntsmcf α 𝔄 𝔅 𝔉 𝔊 𝔑 for α 𝔄 𝔅 𝔉 𝔊 𝔑 +
assumes tiny_ntsmcf_is_tdghm[slicing_intros]: "ntsmcf_tdghm 𝔑 :
smcf_dghm 𝔉 ↦⇩D⇩G⇩H⇩M⇩.⇩t⇩i⇩n⇩y smcf_dghm 𝔊 : smc_dg 𝔄 ↦↦⇩D⇩G⇩.⇩t⇩i⇩n⇩y⇘α⇙ smc_dg 𝔅"
syntax "_is_tiny_ntsmcf" :: "V ⇒ V ⇒ V ⇒ V ⇒ V ⇒ V ⇒ bool"
(‹(_ :/ _ ↦⇩S⇩M⇩C⇩F⇩.⇩t⇩i⇩n⇩y _ :/ _ ↦↦⇩S⇩M⇩C⇩.⇩t⇩i⇩n⇩yı _)› [51, 51, 51, 51, 51] 51)
translations "𝔑 : 𝔉 ↦⇩S⇩M⇩C⇩F⇩.⇩t⇩i⇩n⇩y 𝔊 : 𝔄 ↦↦⇩S⇩M⇩C⇩.⇩t⇩i⇩n⇩y⇘α⇙ 𝔅" ⇌
"CONST is_tiny_ntsmcf α 𝔄 𝔅 𝔉 𝔊 𝔑"
abbreviation all_tiny_ntsmcfs :: "V ⇒ V"
where "all_tiny_ntsmcfs α ≡
set {𝔑. ∃𝔉 𝔊 𝔄 𝔅. 𝔑 : 𝔉 ↦⇩S⇩M⇩C⇩F⇩.⇩t⇩i⇩n⇩y 𝔊 : 𝔄 ↦↦⇩S⇩M⇩C⇩.⇩t⇩i⇩n⇩y⇘α⇙ 𝔅}"
abbreviation tiny_ntsmcfs :: "V ⇒ V ⇒ V ⇒ V"
where "tiny_ntsmcfs α 𝔄 𝔅 ≡
set {𝔑. ∃𝔉 𝔊. 𝔑 : 𝔉 ↦⇩S⇩M⇩C⇩F⇩.⇩t⇩i⇩n⇩y 𝔊 : 𝔄 ↦↦⇩S⇩M⇩C⇩.⇩t⇩i⇩n⇩y⇘α⇙ 𝔅}"
abbreviation these_tiny_ntsmcfs :: "V ⇒ V ⇒ V ⇒ V ⇒ V ⇒ V"
where "these_tiny_ntsmcfs α 𝔄 𝔅 𝔉 𝔊 ≡
set {𝔑. 𝔑 : 𝔉 ↦⇩S⇩M⇩C⇩F⇩.⇩t⇩i⇩n⇩y 𝔊 : 𝔄 ↦↦⇩S⇩M⇩C⇩.⇩t⇩i⇩n⇩y⇘α⇙ 𝔅}"
lemma (in is_tiny_ntsmcf) tiny_ntsmcf_is_tdghm':
assumes "α' = α"
and "𝔉' = smcf_dghm 𝔉"
and "𝔊' = smcf_dghm 𝔊"
and "𝔄' = smc_dg 𝔄"
and "𝔅' = smc_dg 𝔅"
shows "ntsmcf_tdghm 𝔑 : 𝔉' ↦⇩D⇩G⇩H⇩M⇩.⇩t⇩i⇩n⇩y 𝔊' : 𝔄' ↦↦⇩D⇩G⇩.⇩t⇩i⇩n⇩y⇘α'⇙ 𝔅'"
unfolding assms by (rule tiny_ntsmcf_is_tdghm)
lemmas [slicing_intros] = is_tiny_ntsmcf.tiny_ntsmcf_is_tdghm'
text‹Rules.›
lemma (in is_tiny_ntsmcf) is_tiny_ntsmcf_axioms'[smc_small_cs_intros]:
assumes "α' = α" and "𝔄' = 𝔄" and "𝔅' = 𝔅" and "𝔉' = 𝔉" and "𝔊' = 𝔊"
shows "𝔑 : 𝔉 ↦⇩S⇩M⇩C⇩F⇩.⇩t⇩i⇩n⇩y 𝔊 : 𝔄 ↦↦⇩S⇩M⇩C⇩.⇩t⇩i⇩n⇩y⇘α⇙ 𝔅"
unfolding assms by (rule is_tiny_ntsmcf_axioms)
mk_ide rf is_tiny_ntsmcf_def[unfolded is_tiny_ntsmcf_axioms_def]
|intro is_tiny_ntsmcfI|
|dest is_tiny_ntsmcfD[dest]|
|elim is_tiny_ntsmcfE[elim]|
text‹Elementary properties.›
sublocale is_tiny_ntsmcf ⊆ NTDom: is_tiny_semifunctor α 𝔄 𝔅 𝔉
using tiny_ntsmcf_is_tdghm
by (intro is_tiny_semifunctorI) (auto simp: smc_cs_intros)
sublocale is_tiny_ntsmcf ⊆ NTCod: is_tiny_semifunctor α 𝔄 𝔅 𝔊
using tiny_ntsmcf_is_tdghm
by (intro is_tiny_semifunctorI) (auto simp: smc_cs_intros)
sublocale is_tiny_ntsmcf ⊆ is_tm_ntsmcf
by (rule is_tm_ntsmcfI')
(auto simp: tiny_ntsmcf_is_tdghm smc_small_cs_intros smc_cs_intros)
text‹Further rules.›
lemma is_tiny_ntsmcfI':
assumes "𝔑 : 𝔉 ↦⇩S⇩M⇩C⇩F 𝔊 : 𝔄 ↦↦⇩S⇩M⇩C⇘α⇙ 𝔅"
and "𝔉 : 𝔄 ↦↦⇩S⇩M⇩C⇩.⇩t⇩i⇩n⇩y⇘α⇙ 𝔅"
and "𝔊 : 𝔄 ↦↦⇩S⇩M⇩C⇩.⇩t⇩i⇩n⇩y⇘α⇙ 𝔅"
shows "𝔑 : 𝔉 ↦⇩S⇩M⇩C⇩F⇩.⇩t⇩i⇩n⇩y 𝔊 : 𝔄 ↦↦⇩S⇩M⇩C⇩.⇩t⇩i⇩n⇩y⇘α⇙ 𝔅"
using assms by (auto intro: is_tiny_ntsmcfI)
lemma is_tiny_ntsmcfD':
assumes "𝔑 : 𝔉 ↦⇩S⇩M⇩C⇩F⇩.⇩t⇩i⇩n⇩y 𝔊 : 𝔄 ↦↦⇩S⇩M⇩C⇩.⇩t⇩i⇩n⇩y⇘α⇙ 𝔅"
shows "𝔑 : 𝔉 ↦⇩S⇩M⇩C⇩F 𝔊 : 𝔄 ↦↦⇩S⇩M⇩C⇘α⇙ 𝔅"
and "𝔉 : 𝔄 ↦↦⇩S⇩M⇩C⇩.⇩t⇩i⇩n⇩y⇘α⇙ 𝔅"
and "𝔊 : 𝔄 ↦↦⇩S⇩M⇩C⇩.⇩t⇩i⇩n⇩y⇘α⇙ 𝔅"
proof-
interpret is_tiny_ntsmcf α 𝔄 𝔅 𝔉 𝔊 𝔑 by (rule assms(1))
show "𝔑 : 𝔉 ↦⇩S⇩M⇩C⇩F 𝔊 : 𝔄 ↦↦⇩S⇩M⇩C⇘α⇙ 𝔅"
and "𝔉 : 𝔄 ↦↦⇩S⇩M⇩C⇩.⇩t⇩i⇩n⇩y⇘α⇙ 𝔅"
and "𝔊 : 𝔄 ↦↦⇩S⇩M⇩C⇩.⇩t⇩i⇩n⇩y⇘α⇙ 𝔅"
by
(
auto
simp: is_ntsmcf_axioms
intro:
NTDom.is_tiny_semifunctor_axioms
NTCod.is_tiny_semifunctor_axioms
)
qed
lemmas [smc_small_cs_intros] = is_tiny_ntsmcfD'(2,3)
lemma is_tiny_ntsmcfE':
assumes "𝔑 : 𝔉 ↦⇩S⇩M⇩C⇩F⇩.⇩t⇩i⇩n⇩y 𝔊 : 𝔄 ↦↦⇩S⇩M⇩C⇩.⇩t⇩i⇩n⇩y⇘α⇙ 𝔅"
obtains "𝔑 : 𝔉 ↦⇩S⇩M⇩C⇩F 𝔊 : 𝔄 ↦↦⇩S⇩M⇩C⇘α⇙ 𝔅"
and "𝔉 : 𝔄 ↦↦⇩S⇩M⇩C⇩.⇩t⇩i⇩n⇩y⇘α⇙ 𝔅"
and "𝔊 : 𝔄 ↦↦⇩S⇩M⇩C⇩.⇩t⇩i⇩n⇩y⇘α⇙ 𝔅"
using assms by (auto dest: is_tiny_ntsmcfD'(2,3))
lemma is_tiny_ntsmcf_iff:
"𝔑 : 𝔉 ↦⇩S⇩M⇩C⇩F⇩.⇩t⇩i⇩n⇩y 𝔊 : 𝔄 ↦↦⇩S⇩M⇩C⇩.⇩t⇩i⇩n⇩y⇘α⇙ 𝔅 ⟷
(
𝔑 : 𝔉 ↦⇩S⇩M⇩C⇩F 𝔊 : 𝔄 ↦↦⇩S⇩M⇩C⇘α⇙ 𝔅 ∧
𝔉 : 𝔄 ↦↦⇩S⇩M⇩C⇩.⇩t⇩i⇩n⇩y⇘α⇙ 𝔅 ∧
𝔊 : 𝔄 ↦↦⇩S⇩M⇩C⇩.⇩t⇩i⇩n⇩y⇘α⇙ 𝔅
)"
using is_tiny_ntsmcfI' is_tiny_ntsmcfD' by (intro iffI) auto
text‹Size.›
lemma (in is_tiny_ntsmcf) tiny_ntsmcf_in_Vset: "𝔑 ∈⇩∘ Vset α"
proof-
note [smc_cs_intros] =
tm_ntsmcf_NTMap_in_Vset
NTDom.tiny_smcf_in_Vset
NTCod.tiny_smcf_in_Vset
NTDom.HomDom.tiny_smc_in_Vset
NTDom.HomCod.tiny_smc_in_Vset
show ?thesis
by (subst ntsmcf_def)
(cs_concl cs_simp: smc_cs_simps cs_intro: smc_cs_intros V_cs_intros)
qed
lemma small_all_tiny_ntsmcfs[simp]:
"small {𝔑. ∃𝔉 𝔊 𝔄 𝔅. 𝔑 : 𝔉 ↦⇩S⇩M⇩C⇩F⇩.⇩t⇩i⇩n⇩y 𝔊 : 𝔄 ↦↦⇩S⇩M⇩C⇩.⇩t⇩i⇩n⇩y⇘α⇙ 𝔅}"
proof(rule down)
show "{𝔑. ∃𝔉 𝔊 𝔄 𝔅. 𝔑 : 𝔉 ↦⇩S⇩M⇩C⇩F⇩.⇩t⇩i⇩n⇩y 𝔊 : 𝔄 ↦↦⇩S⇩M⇩C⇩.⇩t⇩i⇩n⇩y⇘α⇙ 𝔅} ⊆
elts (set {𝔑. ∃𝔉 𝔊 𝔄 𝔅. 𝔑 : 𝔉 ↦⇩S⇩M⇩C⇩F 𝔊 : 𝔄 ↦↦⇩S⇩M⇩C⇘α⇙ 𝔅})"
proof
(
simp only: elts_of_set small_all_ntsmcfs if_True,
rule subsetI,
unfold mem_Collect_eq
)
fix 𝔑 assume "∃𝔉 𝔊 𝔄 𝔅. 𝔑 : 𝔉 ↦⇩S⇩M⇩C⇩F⇩.⇩t⇩i⇩n⇩y 𝔊 : 𝔄 ↦↦⇩S⇩M⇩C⇩.⇩t⇩i⇩n⇩y⇘α⇙ 𝔅"
then obtain 𝔉 𝔊 𝔄 𝔅 where "𝔑 : 𝔉 ↦⇩S⇩M⇩C⇩F⇩.⇩t⇩i⇩n⇩y 𝔊 : 𝔄 ↦↦⇩S⇩M⇩C⇩.⇩t⇩i⇩n⇩y⇘α⇙ 𝔅"
by clarsimp
then interpret is_tiny_ntsmcf α 𝔄 𝔅 𝔉 𝔊 𝔑 .
have "𝔑 : 𝔉 ↦⇩S⇩M⇩C⇩F 𝔊 : 𝔄 ↦↦⇩S⇩M⇩C⇘α⇙ 𝔅"
by (auto intro: smc_cs_intros)
then show "∃𝔉 𝔊 𝔄 𝔅. 𝔑 : 𝔉 ↦⇩S⇩M⇩C⇩F 𝔊 : 𝔄 ↦↦⇩S⇩M⇩C⇘α⇙ 𝔅" by auto
qed
qed
lemma small_tiny_ntsmcfs[simp]:
"small {𝔑. ∃𝔉 𝔊. 𝔑 : 𝔉 ↦⇩S⇩M⇩C⇩F⇩.⇩t⇩i⇩n⇩y 𝔊 : 𝔄 ↦↦⇩S⇩M⇩C⇩.⇩t⇩i⇩n⇩y⇘α⇙ 𝔅}"
by
(
rule
down[
of
_
‹set {𝔑. ∃𝔉 𝔊 𝔄 𝔅. 𝔑 : 𝔉 ↦⇩S⇩M⇩C⇩F⇩.⇩t⇩i⇩n⇩y 𝔊 : 𝔄 ↦↦⇩S⇩M⇩C⇩.⇩t⇩i⇩n⇩y⇘α⇙ 𝔅}›
]
)
auto
lemma small_these_tiny_ntcfs[simp]:
"small {𝔑. 𝔑 : 𝔉 ↦⇩S⇩M⇩C⇩F⇩.⇩t⇩i⇩n⇩y 𝔊 : 𝔄 ↦↦⇩S⇩M⇩C⇩.⇩t⇩i⇩n⇩y⇘α⇙ 𝔅}"
by
(
rule down[
of _ ‹set {𝔑. ∃𝔉 𝔊 𝔄 𝔅. 𝔑 : 𝔉 ↦⇩S⇩M⇩C⇩F⇩.⇩t⇩i⇩n⇩y 𝔊 : 𝔄 ↦↦⇩S⇩M⇩C⇩.⇩t⇩i⇩n⇩y⇘α⇙ 𝔅}›
]
)
auto
lemma tiny_ntsmcfs_vsubset_Vset[simp]:
"set {𝔑. ∃𝔉 𝔊. 𝔑 : 𝔉 ↦⇩S⇩M⇩C⇩F⇩.⇩t⇩i⇩n⇩y 𝔊 : 𝔄 ↦↦⇩S⇩M⇩C⇩.⇩t⇩i⇩n⇩y⇘α⇙ 𝔅} ⊆⇩∘ Vset α"
(is ‹set ?ntsmcfs ⊆⇩∘ _›)
proof(cases ‹tiny_semicategory α 𝔄 ∧ tiny_semicategory α 𝔅›)
case True
then have "tiny_semicategory α 𝔄" and "tiny_semicategory α 𝔅" by auto
show ?thesis
proof(rule vsubsetI)
fix 𝔑 assume "𝔑 ∈⇩∘ set ?ntsmcfs"
then obtain 𝔉 𝔊 where "𝔑 : 𝔉 ↦⇩S⇩M⇩C⇩F⇩.⇩t⇩i⇩n⇩y 𝔊 : 𝔄 ↦↦⇩S⇩M⇩C⇩.⇩t⇩i⇩n⇩y⇘α⇙ 𝔅" by auto
then interpret is_tiny_ntsmcf α 𝔄 𝔅 𝔉 𝔊 𝔑 .
from tiny_ntsmcf_in_Vset show "𝔑 ∈⇩∘ Vset α" by simp
qed
next
case False
then have "set ?ntsmcfs = 0"
unfolding is_tiny_ntsmcf_iff is_tiny_semifunctor_iff by auto
then show ?thesis by simp
qed
lemma (in is_ntsmcf) ntsmcf_is_tiny_ntsmcf_if_ge_Limit:
assumes "𝒵 β" and "α ∈⇩∘ β"
shows "𝔑 : 𝔉 ↦⇩S⇩M⇩C⇩F⇩.⇩t⇩i⇩n⇩y 𝔊 : 𝔄 ↦↦⇩S⇩M⇩C⇩.⇩t⇩i⇩n⇩y⇘β⇙ 𝔅"
proof(intro is_tiny_ntsmcfI)
interpret β: 𝒵 β by (rule assms(1))
show "𝔑 : 𝔉 ↦⇩S⇩M⇩C⇩F 𝔊 : 𝔄 ↦↦⇩S⇩M⇩C⇘β⇙ 𝔅"
by (intro ntsmcf_is_ntsmcf_if_ge_Limit)
(use assms(2) in ‹cs_concl cs_intro: dg_cs_intros›)+
show "ntsmcf_tdghm 𝔑 :
smcf_dghm 𝔉 ↦⇩D⇩G⇩H⇩M⇩.⇩t⇩i⇩n⇩y smcf_dghm 𝔊 : smc_dg 𝔄 ↦↦⇩D⇩G⇩.⇩t⇩i⇩n⇩y⇘β⇙ smc_dg 𝔅"
by
(
rule is_tdghm.tdghm_is_tiny_tdghm_if_ge_Limit,
rule ntsmcf_is_tdghm;
intro assms
)
qed
text‹Further elementary results.›
lemma these_tiny_ntsmcfs_iff:
"𝔑 ∈⇩∘ these_tiny_ntsmcfs α 𝔄 𝔅 𝔉 𝔊 ⟷
𝔑 : 𝔉 ↦⇩S⇩M⇩C⇩F⇩.⇩t⇩i⇩n⇩y 𝔊 : 𝔄 ↦↦⇩S⇩M⇩C⇩.⇩t⇩i⇩n⇩y⇘α⇙ 𝔅"
by auto
subsubsection‹Opposite natural transformation of tiny semifunctors›
lemma (in is_tiny_ntsmcf) is_tm_ntsmcf_op: "op_ntsmcf 𝔑 :
op_smcf 𝔊 ↦⇩S⇩M⇩C⇩F⇩.⇩t⇩i⇩n⇩y op_smcf 𝔉 : op_smc 𝔄 ↦↦⇩S⇩M⇩C⇩.⇩t⇩i⇩n⇩y⇘α⇙ op_smc 𝔅"
by (intro is_tiny_ntsmcfI')
(cs_concl cs_intro: smc_cs_intros smc_op_intros)+
lemma (in is_tiny_ntsmcf) is_tiny_ntsmcf_op'[smc_op_intros]:
assumes "𝔊' = op_smcf 𝔊"
and "𝔉' = op_smcf 𝔉"
and "𝔄' = op_smc 𝔄"
and "𝔅' = op_smc 𝔅"
shows "op_ntsmcf 𝔑 : 𝔊' ↦⇩S⇩M⇩C⇩F⇩.⇩t⇩i⇩n⇩y 𝔉' : 𝔄' ↦↦⇩S⇩M⇩C⇩.⇩t⇩i⇩n⇩y⇘α⇙ 𝔅'"
unfolding assms by (rule is_tm_ntsmcf_op)
lemmas is_tiny_ntsmcf_op[smc_op_intros] = is_tiny_ntsmcf.is_tiny_ntsmcf_op'
subsubsection‹
Vertical composition of tiny natural transformations of
semifunctors
›
lemma ntsmcf_vcomp_is_tiny_ntsmcf[smc_small_cs_intros]:
assumes "𝔐 : 𝔊 ↦⇩S⇩M⇩C⇩F⇩.⇩t⇩i⇩n⇩y ℌ : 𝔄 ↦↦⇩S⇩M⇩C⇩.⇩t⇩i⇩n⇩y⇘α⇙ 𝔅"
and "𝔑 : 𝔉 ↦⇩S⇩M⇩C⇩F⇩.⇩t⇩i⇩n⇩y 𝔊 : 𝔄 ↦↦⇩S⇩M⇩C⇩.⇩t⇩i⇩n⇩y⇘α⇙ 𝔅"
shows "𝔐 ∙⇩N⇩T⇩S⇩M⇩C⇩F 𝔑 : 𝔉 ↦⇩S⇩M⇩C⇩F⇩.⇩t⇩i⇩n⇩y ℌ : 𝔄 ↦↦⇩S⇩M⇩C⇩.⇩t⇩i⇩n⇩y⇘α⇙ 𝔅"
proof-
interpret 𝔐: is_tiny_ntsmcf α 𝔄 𝔅 𝔊 ℌ 𝔐 by (rule assms(1))
interpret 𝔑: is_tiny_ntsmcf α 𝔄 𝔅 𝔉 𝔊 𝔑 by (rule assms(2))
show ?thesis by (rule is_tiny_ntsmcfI') (auto intro: smc_small_cs_intros)
qed
text‹\newpage›
end
Theory CZH_SMC_PSemicategory
section‹Product semicategory›
theory CZH_SMC_PSemicategory
imports
CZH_SMC_Semifunctor
CZH_SMC_Small_Semicategory
CZH_DG_PDigraph
begin
subsection‹Background›
text‹
The concept of a product semicategory, as presented in this work,
is a generalization of the concept of a product category, as presented in
Chapter II-3 in \cite{mac_lane_categories_2010}.
›
named_theorems smc_prod_cs_simps
named_theorems smc_prod_cs_intros
subsection‹Product semicategory: definition and elementary properties›
definition smc_prod :: "V ⇒ (V ⇒ V) ⇒ V"
where "smc_prod I 𝔄 =
[
(∏⇩∘i∈⇩∘I. 𝔄 i⦇Obj⦈),
(∏⇩∘i∈⇩∘I. 𝔄 i⦇Arr⦈),
(λf∈⇩∘(∏⇩∘i∈⇩∘I. 𝔄 i⦇Arr⦈). (λi∈⇩∘I. 𝔄 i⦇Dom⦈⦇f⦇i⦈⦈)),
(λf∈⇩∘(∏⇩∘i∈⇩∘I. 𝔄 i⦇Arr⦈). (λi∈⇩∘I. 𝔄 i⦇Cod⦈⦇f⦇i⦈⦈)),
(λgf∈⇩∘composable_arrs (dg_prod I 𝔄). (λi∈⇩∘I. gf⦇0⦈⦇i⦈ ∘⇩A⇘𝔄 i⇙ gf⦇1⇩ℕ⦈⦇i⦈))
]⇩∘"
syntax "_PSEMICATEGORY" :: "pttrn ⇒ V ⇒ (V ⇒ V) ⇒ V"
("(3∏⇩S⇩M⇩C_∈⇩∘_./ _)" [0, 0, 10] 10)
translations "∏⇩S⇩M⇩Ci∈⇩∘I. 𝔄" ⇌ "CONST smc_prod I (λi. 𝔄)"
text‹Components.›
lemma smc_prod_components:
shows "(∏⇩S⇩M⇩Ci∈⇩∘I. 𝔄 i)⦇Obj⦈ = (∏⇩∘i∈⇩∘I. 𝔄 i⦇Obj⦈)"
and "(∏⇩S⇩M⇩Ci∈⇩∘I. 𝔄 i)⦇Arr⦈ = (∏⇩∘i∈⇩∘I. 𝔄 i⦇Arr⦈)"
and "(∏⇩S⇩M⇩Ci∈⇩∘I. 𝔄 i)⦇Dom⦈ =
(λf∈⇩∘(∏⇩∘i∈⇩∘I. 𝔄 i⦇Arr⦈). (λi∈⇩∘I. 𝔄 i⦇Dom⦈⦇f⦇i⦈⦈))"
and "(∏⇩S⇩M⇩Ci∈⇩∘I. 𝔄 i)⦇Cod⦈ =
(λf∈⇩∘(∏⇩∘i∈⇩∘I. 𝔄 i⦇Arr⦈). (λi∈⇩∘I. 𝔄 i⦇Cod⦈⦇f⦇i⦈⦈))"
and "(∏⇩S⇩M⇩Ci∈⇩∘I. 𝔄 i)⦇Comp⦈ =
(λgf∈⇩∘composable_arrs (dg_prod I 𝔄). (λi∈⇩∘I. gf⦇0⦈⦇i⦈ ∘⇩A⇘𝔄 i⇙ gf⦇1⇩ℕ⦈⦇i⦈))"
unfolding smc_prod_def dg_field_simps by (simp_all add: nat_omega_simps)
text‹Slicing.›
lemma smc_dg_smc_prod[slicing_commute]:
"dg_prod I (λi. smc_dg (𝔄 i)) = smc_dg (smc_prod I 𝔄)"
unfolding dg_prod_def smc_dg_def smc_prod_def dg_field_simps
by (simp_all add: nat_omega_simps)
context
fixes 𝔄 φ :: "V ⇒ V"
and ℭ :: V
begin
lemmas_with
[where 𝔄=‹λi. smc_dg (𝔄 i)›, unfolded slicing_simps slicing_commute]:
smc_prod_ObjI = dg_prod_ObjI
and smc_prod_ObjD = dg_prod_ObjD
and smc_prod_ObjE = dg_prod_ObjE
and smc_prod_Obj_cong = dg_prod_Obj_cong
and smc_prod_ArrI = dg_prod_ArrI
and smc_prod_ArrD = dg_prod_ArrD
and smc_prod_ArrE = dg_prod_ArrE
and smc_prod_Arr_cong = dg_prod_Arr_cong
and smc_prod_Dom_vsv[smc_cs_intros] = dg_prod_Dom_vsv
and smc_prod_Dom_vdomain[smc_cs_simps] = dg_prod_Dom_vdomain
and smc_prod_Dom_app = dg_prod_Dom_app
and smc_prod_Dom_app_component_app[smc_cs_simps] =
dg_prod_Dom_app_component_app
and smc_prod_Cod_vsv[smc_cs_intros] = dg_prod_Cod_vsv
and smc_prod_Cod_app = dg_prod_Cod_app
and smc_prod_Cod_vdomain[smc_cs_simps] = dg_prod_Cod_vdomain
and smc_prod_Cod_app_component_app[smc_cs_simps] =
dg_prod_Cod_app_component_app
and smc_prod_vunion_Obj_in_Obj = dg_prod_vunion_Obj_in_Obj
and smc_prod_vdiff_vunion_Obj_in_Obj = dg_prod_vdiff_vunion_Obj_in_Obj
and smc_prod_vunion_Arr_in_Arr = dg_prod_vunion_Arr_in_Arr
and smc_prod_vdiff_vunion_Arr_in_Arr = dg_prod_vdiff_vunion_Arr_in_Arr
end
lemma smc_prod_dg_prod_is_arr:
"g : b ↦⇘∏⇩D⇩Gi∈⇩∘I. 𝔄 i⇙ c ⟷ g : b ↦⇘∏⇩S⇩M⇩Ci∈⇩∘I. 𝔄 i⇙ c"
unfolding is_arr_def smc_prod_def dg_prod_def dg_field_simps
by (simp add: nat_omega_simps)
lemma smc_prod_composable_arrs_dg_prod:
"composable_arrs (∏⇩D⇩Gi∈⇩∘I. 𝔄 i) = composable_arrs (∏⇩S⇩M⇩Ci∈⇩∘I. 𝔄 i)"
unfolding composable_arrs_def smc_prod_dg_prod_is_arr by simp
subsection‹Local assumptions for a product semicategory›
locale psemicategory_base = 𝒵 α for α I 𝔄 +
assumes psmc_semicategories[smc_prod_cs_intros]:
"i ∈⇩∘ I ⟹ semicategory α (𝔄 i)"
and psmc_index_in_Vset[smc_cs_intros]: "I ∈⇩∘ Vset α"
text‹Rules.›
lemma (in psemicategory_base) psemicategory_base_axioms'[smc_prod_cs_intros]:
assumes "α' = α" and "I' = I"
shows "psemicategory_base α' I' 𝔄"
unfolding assms by (rule psemicategory_base_axioms)
mk_ide rf psemicategory_base_def[unfolded psemicategory_base_axioms_def]
|intro psemicategory_baseI|
|dest psemicategory_baseD[dest]|
|elim psemicategory_baseE[elim]|
lemma psemicategory_base_pdigraph_baseI:
assumes "pdigraph_base α I (λi. smc_dg (𝔄 i))"
and "⋀i. i ∈⇩∘ I ⟹ semicategory α (𝔄 i)"
shows "psemicategory_base α I 𝔄"
proof-
interpret pdigraph_base α I ‹λi. smc_dg (𝔄 i)›
rewrites "smc_dg ℭ'⦇Obj⦈ = ℭ'⦇Obj⦈" and "smc_dg ℭ'⦇Arr⦈ = ℭ'⦇Arr⦈" for ℭ'
by (rule assms(1)) (simp_all add: slicing_simps)
show ?thesis
by (intro psemicategory_baseI)
(auto simp: assms(2) pdg_index_in_Vset pdg_Obj_in_Vset pdg_Arr_in_Vset)
qed
text‹Product semicategory is a product digraph.›
context psemicategory_base
begin
lemma psmc_pdigraph_base: "pdigraph_base α I (λi. smc_dg (𝔄 i))"
proof(intro pdigraph_baseI)
show "digraph α (smc_dg (𝔄 i))" if "i ∈⇩∘ I" for i
using that by (cs_concl cs_intro: slicing_intros smc_prod_cs_intros)
show "I ∈⇩∘ Vset α" by (cs_concl cs_intro: smc_cs_intros)
qed auto
interpretation pdg: pdigraph_base α I ‹λi. smc_dg (𝔄 i)›
by (rule psmc_pdigraph_base)
lemmas_with [unfolded slicing_simps slicing_commute]:
psmc_Obj_in_Vset = pdg.pdg_Obj_in_Vset
and psmc_Arr_in_Vset = pdg.pdg_Arr_in_Vset
and psmc_smc_prod_Obj_in_Vset = pdg.pdg_dg_prod_Obj_in_Vset
and psmc_smc_prod_Arr_in_Vset = pdg.pdg_dg_prod_Arr_in_Vset
and smc_prod_Dom_app_in_Obj[smc_cs_intros] = pdg.dg_prod_Dom_app_in_Obj
and smc_prod_Cod_app_in_Obj[smc_cs_intros] = pdg.dg_prod_Cod_app_in_Obj
and smc_prod_is_arrI = pdg.dg_prod_is_arrI
and smc_prod_is_arrD[dest] = pdg.dg_prod_is_arrD
and smc_prod_is_arrE[elim] = pdg.dg_prod_is_arrE
end
lemmas [smc_cs_intros] = psemicategory_base.smc_prod_is_arrD(7)
text‹Elementary properties.›
lemma (in psemicategory_base) psmc_vsubset_index_psemicategory_base:
assumes "J ⊆⇩∘ I"
shows "psemicategory_base α J 𝔄"
proof(intro psemicategory_baseI)
show "semicategory α (𝔄 i)" if "i ∈⇩∘ J" for i
using that assms by (auto intro: smc_prod_cs_intros)
from assms show "J ∈⇩∘ Vset α" by (simp add: vsubset_in_VsetI smc_cs_intros)
qed auto
subsubsection‹Composition›
lemma smc_prod_Comp:
"(∏⇩S⇩M⇩Ci∈⇩∘I. 𝔄 i)⦇Comp⦈ =
(
λgf∈⇩∘composable_arrs (∏⇩S⇩M⇩Ci∈⇩∘I. 𝔄 i).
(λi∈⇩∘I. gf⦇0⦈⦇i⦈ ∘⇩A⇘𝔄 i⇙ gf⦇1⇩ℕ⦈⦇i⦈)
)"
unfolding smc_prod_components smc_prod_composable_arrs_dg_prod by simp
lemma smc_prod_Comp_vdomain[smc_cs_simps]:
"𝒟⇩∘ ((∏⇩S⇩M⇩Ci∈⇩∘I. 𝔄 i)⦇Comp⦈) = composable_arrs (∏⇩S⇩M⇩Ci∈⇩∘I. 𝔄 i)"
unfolding smc_prod_Comp by simp
lemma smc_prod_Comp_app:
assumes "g : b ↦⇘∏⇩S⇩M⇩Ci∈⇩∘I. 𝔄 i⇙ c" and "f : a ↦⇘∏⇩S⇩M⇩Ci∈⇩∘I. 𝔄 i⇙ b"
shows "g ∘⇩A⇘(∏⇩S⇩M⇩Ci∈⇩∘I. 𝔄 i)⇙ f = (λi∈⇩∘I. g⦇i⦈ ∘⇩A⇘𝔄 i⇙ f⦇i⦈)"
proof-
from assms have "[g, f]⇩∘ ∈⇩∘ composable_arrs (∏⇩S⇩M⇩Ci∈⇩∘I. 𝔄 i)"
by (auto intro: smc_cs_intros)
then show ?thesis unfolding smc_prod_Comp by (auto simp: nat_omega_simps)
qed
lemma smc_prod_Comp_app_component[smc_cs_simps]:
assumes "g : b ↦⇘∏⇩S⇩M⇩Ci∈⇩∘I. 𝔄 i⇙ c"
and "f : a ↦⇘∏⇩S⇩M⇩Ci∈⇩∘I. 𝔄 i⇙ b"
and "i ∈⇩∘ I"
shows "(g ∘⇩A⇘(∏⇩S⇩M⇩Ci∈⇩∘I. 𝔄 i)⇙ f)⦇i⦈ = g⦇i⦈ ∘⇩A⇘𝔄 i⇙ f⦇i⦈"
using assms(3) unfolding smc_prod_Comp_app[OF assms(1,2)] by simp
lemma (in psemicategory_base) smc_prod_Comp_vrange:
"ℛ⇩∘ ((∏⇩S⇩M⇩Ci∈⇩∘I. 𝔄 i)⦇Comp⦈) ⊆⇩∘ (∏⇩S⇩M⇩Ci∈⇩∘I. 𝔄 i)⦇Arr⦈"
proof(intro vsubsetI)
fix h assume prems: "h ∈⇩∘ ℛ⇩∘ ((∏⇩S⇩M⇩Ci∈⇩∘I. 𝔄 i)⦇Comp⦈)"
then obtain gf
where h_def: "h = (∏⇩S⇩M⇩Ci∈⇩∘I. 𝔄 i)⦇Comp⦈⦇gf⦈"
and "gf ∈⇩∘ composable_arrs (∏⇩S⇩M⇩Ci∈⇩∘I. 𝔄 i)"
by (auto simp: smc_prod_Comp intro: smc_cs_intros)
then obtain g f a b c
where gf_def: "gf = [g, f]⇩∘"
and g: "g : b ↦⇘∏⇩S⇩M⇩Ci∈⇩∘I. 𝔄 i⇙ c"
and f: "f : a ↦⇘∏⇩S⇩M⇩Ci∈⇩∘I. 𝔄 i⇙ b"
by clarsimp
from g f have gf_comp: "g ∘⇩A⇘(∏⇩S⇩M⇩Ci∈⇩∘I. 𝔄 i)⇙ f = (λi∈⇩∘I. g⦇i⦈ ∘⇩A⇘𝔄 i⇙ f⦇i⦈)"
by (rule smc_prod_Comp_app)
show "h ∈⇩∘ (∏⇩S⇩M⇩Ci∈⇩∘I. 𝔄 i)⦇Arr⦈"
unfolding smc_prod_components
unfolding h_def gf_def gf_comp
proof(rule VLambda_in_vproduct)
fix i assume prems: "i ∈⇩∘ I"
interpret semicategory α ‹𝔄 i›
using prems by (simp add: smc_prod_cs_intros)
from prems smc_prod_is_arrD(7)[OF g] smc_prod_is_arrD(7)[OF f] have
"g⦇i⦈ ∘⇩A⇘𝔄 i⇙ f⦇i⦈ : a⦇i⦈ ↦⇘𝔄 i⇙ c⦇i⦈"
by (auto intro: smc_cs_intros)
then show "g⦇i⦈ ∘⇩A⇘𝔄 i⇙ f⦇i⦈ ∈⇩∘ 𝔄 i⦇Arr⦈" by (simp add: smc_cs_intros)
qed
qed
lemma smc_prod_Comp_app_vdomain[smc_cs_simps]:
assumes "g : b ↦⇘∏⇩S⇩M⇩Ci∈⇩∘I. 𝔄 i⇙ c" and "f : a ↦⇘∏⇩S⇩M⇩Ci∈⇩∘I. 𝔄 i⇙ b"
shows "𝒟⇩∘ (g ∘⇩A⇘(∏⇩S⇩M⇩Ci∈⇩∘I. 𝔄 i)⇙ f) = I"
unfolding smc_prod_Comp_app[OF assms] by simp
subsubsection‹A product ‹α›-semicategory is a tiny ‹β›-semicategory›
lemma (in psemicategory_base) psmc_tiny_semicategory_smc_prod:
assumes "𝒵 β" and "α ∈⇩∘ β"
shows "tiny_semicategory β (∏⇩S⇩M⇩Ci∈⇩∘I. 𝔄 i)"
proof(intro tiny_semicategoryI, (unfold slicing_simps)?)
show "tiny_digraph β (smc_dg (smc_prod I 𝔄))"
unfolding slicing_commute[symmetric]
by
(
intro pdigraph_base.pdg_tiny_digraph_dg_prod;
(rule assms psmc_pdigraph_base)?
)
show "vfsequence (∏⇩S⇩M⇩Ci∈⇩∘I. 𝔄 i)" unfolding smc_prod_def by auto
show "vcard (∏⇩S⇩M⇩Ci∈⇩∘I. 𝔄 i) = 5⇩ℕ"
unfolding smc_prod_def by (simp add: nat_omega_simps)
show "vsv ((∏⇩S⇩M⇩Ci∈⇩∘I. 𝔄 i)⦇Comp⦈)" unfolding smc_prod_Comp by simp
show
"(gf ∈⇩∘ 𝒟⇩∘ ((∏⇩S⇩M⇩Ci∈⇩∘I. 𝔄 i)⦇Comp⦈)) ⟷
(
∃g f b c a.
gf = [g, f]⇩∘ ∧ g : b ↦⇘smc_prod I 𝔄⇙ c ∧ f : a ↦⇘smc_prod I 𝔄⇙ b
)"
for gf
by (auto intro: smc_cs_intros simp: smc_cs_simps)
show Comp_is_arr[intro]: "g ∘⇩A⇘(∏⇩S⇩M⇩Ci∈⇩∘I. 𝔄 i)⇙ f : a ↦⇘∏⇩S⇩M⇩Ci∈⇩∘I. 𝔄 i⇙ c"
if "g : b ↦⇘∏⇩S⇩M⇩Ci∈⇩∘I. 𝔄 i⇙ c" and "f : a ↦⇘∏⇩S⇩M⇩Ci∈⇩∘I. 𝔄 i⇙ b"
for g b c f a
proof(intro smc_prod_is_arrI)
from that show "vsv (g ∘⇩A⇘smc_prod I 𝔄⇙ f)"
by (auto simp: smc_prod_Comp_app)
from that show "𝒟⇩∘ (g ∘⇩A⇘smc_prod I 𝔄⇙ f) = I"
by (auto simp: smc_prod_Comp_app)
from that(2) have f: "f ∈⇩∘ (∏⇩S⇩M⇩Ci∈⇩∘I. 𝔄 i)⦇Arr⦈"
by (elim is_arrE) (auto simp: smc_prod_components)
from that(1) have g: "g ∈⇩∘ (∏⇩S⇩M⇩Ci∈⇩∘I. 𝔄 i)⦇Arr⦈"
by (elim is_arrE) (auto simp: smc_prod_components)
from f have a: "a ∈⇩∘ (∏⇩S⇩M⇩Ci∈⇩∘I. 𝔄 i)⦇Obj⦈"
by (rule smc_prod_Dom_app_in_Obj[of f, unfolded is_arrD(2)[OF that(2)]])
then show "vsv a" by (auto simp: smc_prod_components)
from a show "𝒟⇩∘ a = I" by (auto simp: smc_prod_components)
from g have c: "c ∈⇩∘ (∏⇩S⇩M⇩Ci∈⇩∘I. 𝔄 i)⦇Obj⦈"
by (rule smc_prod_Cod_app_in_Obj[of g, unfolded is_arrD(3)[OF that(1)]])
then show "vsv c" by (auto simp: smc_prod_components)
from c show "𝒟⇩∘ c = I" by (auto simp: smc_prod_components)
fix i assume prems: "i ∈⇩∘ I"
interpret semicategory α ‹𝔄 i›
using prems by (auto intro: smc_prod_cs_intros)
from
prems
smc_prod_is_arrD(7)[OF that(1) prems]
smc_prod_is_arrD(7)[OF that(2) prems]
show "(g ∘⇩A⇘smc_prod I 𝔄⇙ f)⦇i⦈ : a⦇i⦈ ↦⇘𝔄 i⇙ c⦇i⦈"
unfolding smc_prod_Comp_app[OF that] by (auto intro: smc_cs_intros)
qed
show
"h ∘⇩A⇘smc_prod I 𝔄⇙ g ∘⇩A⇘smc_prod I 𝔄⇙ f =
h ∘⇩A⇘smc_prod I 𝔄⇙ (g ∘⇩A⇘smc_prod I 𝔄⇙ f)"
if "h : c ↦⇘smc_prod I 𝔄⇙ d"
and "g : b ↦⇘smc_prod I 𝔄⇙ c"
and "f : a ↦⇘smc_prod I 𝔄⇙ b"
for h c d g b f a
proof(rule smc_prod_Arr_cong)
show "(h ∘⇩A⇘smc_prod I 𝔄⇙ g) ∘⇩A⇘smc_prod I 𝔄⇙ f ∈⇩∘ (∏⇩S⇩M⇩Ci∈⇩∘I. 𝔄 i)⦇Arr⦈"
by (meson that Comp_is_arr is_arrD)
show "h ∘⇩A⇘smc_prod I 𝔄⇙ (g ∘⇩A⇘smc_prod I 𝔄⇙ f) ∈⇩∘ smc_prod I 𝔄⦇Arr⦈"
by (meson that Comp_is_arr is_arrD)
fix i assume prems: "i ∈⇩∘ I"
then interpret semicategory α ‹𝔄 i› by (simp add: smc_prod_cs_intros)
from prems that have "h⦇i⦈ : c⦇i⦈ ↦⇘𝔄 i⇙ d⦇i⦈"
and "g⦇i⦈ : b⦇i⦈ ↦⇘𝔄 i⇙ c⦇i⦈"
and "f⦇i⦈ : a⦇i⦈ ↦⇘𝔄 i⇙ b⦇i⦈"
and "h ∘⇩A⇘smc_prod I 𝔄⇙ g : b ↦⇘smc_prod I 𝔄⇙ d"
and "g ∘⇩A⇘smc_prod I 𝔄⇙ f : a ↦⇘smc_prod I 𝔄⇙ c"
by (auto simp: smc_prod_is_arrD)
with prems that show
"(h ∘⇩A⇘smc_prod I 𝔄⇙ g ∘⇩A⇘smc_prod I 𝔄⇙ f)⦇i⦈ =
(h ∘⇩A⇘smc_prod I 𝔄⇙ (g ∘⇩A⇘smc_prod I 𝔄⇙ f))⦇i⦈"
by (simp add: smc_prod_Comp_app_component smc_Comp_assoc)
qed
qed (intro assms)
subsection‹Further local assumptions for product semicategories›
subsubsection‹Definition and elementary properties›
locale psemicategory = psemicategory_base α I 𝔄 for α I 𝔄 +
assumes psmc_Obj_vsubset_Vset:
"J ⊆⇩∘ I ⟹ (∏⇩S⇩M⇩Ci∈⇩∘J. 𝔄 i)⦇Obj⦈ ⊆⇩∘ Vset α"
and psmc_Hom_vifunion_in_Vset:
"⟦
J ⊆⇩∘ I;
A ⊆⇩∘ (∏⇩S⇩M⇩Ci∈⇩∘J. 𝔄 i)⦇Obj⦈;
B ⊆⇩∘ (∏⇩S⇩M⇩Ci∈⇩∘J. 𝔄 i)⦇Obj⦈;
A ∈⇩∘ Vset α;
B ∈⇩∘ Vset α
⟧ ⟹ (⋃⇩∘a∈⇩∘A. ⋃⇩∘b∈⇩∘B. Hom (∏⇩S⇩M⇩Ci∈⇩∘J. 𝔄 i) a b) ∈⇩∘ Vset α"
text‹Rules.›
lemma (in psemicategory) psemicategory_axioms'[smc_prod_cs_intros]:
assumes "α' = α" and "I' = I"
shows "psemicategory α' I' 𝔄"
unfolding assms by (rule psemicategory_axioms)
mk_ide rf psemicategory_def[unfolded psemicategory_axioms_def]
|intro psemicategoryI|
|dest psemicategoryD[dest]|
|elim psemicategoryE[elim]|
lemmas [smc_prod_cs_intros] = psemicategoryD(1)
lemma psemicategory_pdigraphI:
assumes "pdigraph α I (λi. smc_dg (𝔄 i))"
and "⋀i. i ∈⇩∘ I ⟹ semicategory α (𝔄 i)"
shows "psemicategory α I 𝔄"
proof-
interpret pdigraph α I ‹λi. smc_dg (𝔄 i)› by (rule assms(1))
note [unfolded slicing_simps slicing_commute, smc_cs_intros] =
pdg_Obj_vsubset_Vset
pdg_Hom_vifunion_in_Vset
show ?thesis
by (intro psemicategoryI psemicategory_base_pdigraph_baseI)
(auto simp: assms(2) dg_prod_cs_intros intro!: smc_cs_intros)
qed
text‹Product semicategory is a product digraph.›
context psemicategory
begin
lemma psmc_pdigraph: "pdigraph α I (λi. smc_dg (𝔄 i))"
proof(intro pdigraphI, unfold slicing_simps slicing_commute)
show "pdigraph_base α I (λi. smc_dg (𝔄 i))" by (rule psmc_pdigraph_base)
qed (auto intro!: psmc_Obj_vsubset_Vset psmc_Hom_vifunion_in_Vset)
interpretation pdg: pdigraph α I ‹λi. smc_dg (𝔄 i)› by (rule psmc_pdigraph)
lemmas_with [unfolded slicing_simps slicing_commute]:
psmc_Obj_vsubset_Vset' = pdg.pdg_Obj_vsubset_Vset'
and psmc_Hom_vifunion_in_Vset' = pdg.pdg_Hom_vifunion_in_Vset'
and psmc_smc_prod_vunion_is_arr = pdg.pdg_dg_prod_vunion_is_arr
and psmc_smc_prod_vdiff_vunion_is_arr = pdg.pdg_dg_prod_vdiff_vunion_is_arr
end
text‹Elementary properties.›
lemma (in psemicategory) psmc_vsubset_index_psemicategory:
assumes "J ⊆⇩∘ I"
shows "psemicategory α J 𝔄"
proof(intro psemicategoryI psemicategory_pdigraphI)
show "smc_prod J' 𝔄⦇Obj⦈ ⊆⇩∘ Vset α" if ‹J' ⊆⇩∘ J› for J'
proof-
from that assms have "J' ⊆⇩∘ I" by simp
then show "smc_prod J' 𝔄⦇Obj⦈ ⊆⇩∘ Vset α" by (rule psmc_Obj_vsubset_Vset)
qed
fix A B J' assume prems:
"J' ⊆⇩∘ J"
"A ⊆⇩∘ (∏⇩S⇩M⇩Ci∈⇩∘J'. 𝔄 i)⦇Obj⦈"
"B ⊆⇩∘ (∏⇩S⇩M⇩Ci∈⇩∘J'. 𝔄 i)⦇Obj⦈"
"A ∈⇩∘ Vset α"
"B ∈⇩∘ Vset α"
show "(⋃⇩∘a∈⇩∘A. ⋃⇩∘b∈⇩∘B. Hom (∏⇩S⇩M⇩Ci∈⇩∘J'. 𝔄 i) a b) ∈⇩∘ Vset α"
proof-
from prems(1) assms have "J' ⊆⇩∘ I" by simp
from psmc_Hom_vifunion_in_Vset[OF this prems(2-5)] show ?thesis.
qed
qed (rule psmc_vsubset_index_psemicategory_base[OF assms])
subsubsection‹A product ‹α›-semicategory is an ‹α›-semicategory›
lemma (in psemicategory) psmc_semicategory_smc_prod:
"semicategory α (∏⇩S⇩M⇩Ci∈⇩∘I. 𝔄 i)"
proof-
interpret tiny_semicategory ‹α + ω› ‹∏⇩S⇩M⇩Ci∈⇩∘I. 𝔄 i›
by (intro psmc_tiny_semicategory_smc_prod)
(auto simp: 𝒵_α_αω 𝒵.intro 𝒵_Limit_αω 𝒵_ω_αω)
show ?thesis
by (rule semicategory_if_semicategory)
(
auto
intro!: psmc_Hom_vifunion_in_Vset psmc_Obj_vsubset_Vset
intro: smc_cs_intros
)
qed
subsection‹Local assumptions for a finite product semicategory›
subsubsection‹Definition and elementary properties›
locale finite_psemicategory = psemicategory_base α I 𝔄 for α I 𝔄 +
assumes fin_psmc_index_vfinite: "vfinite I"
text‹Rules.›
lemma (in finite_psemicategory) finite_psemicategory_axioms[smc_prod_cs_intros]:
assumes "α' = α" and "I' = I"
shows "finite_psemicategory α' I' 𝔄"
unfolding assms by (rule finite_psemicategory_axioms)
mk_ide rf finite_psemicategory_def[unfolded finite_psemicategory_axioms_def]
|intro finite_psemicategoryI|
|dest finite_psemicategoryD[dest]|
|elim finite_psemicategoryE[elim]|
lemmas [smc_prod_cs_intros] = finite_psemicategoryD(1)
lemma finite_psemicategory_finite_pdigraphI:
assumes "finite_pdigraph α I (λi. smc_dg (𝔄 i))"
and "⋀i. i ∈⇩∘ I ⟹ semicategory α (𝔄 i)"
shows "finite_psemicategory α I 𝔄"
proof-
interpret finite_pdigraph α I ‹λi. smc_dg (𝔄 i)› by (rule assms(1))
show ?thesis
by
(
intro
assms
finite_psemicategoryI
psemicategory_base_pdigraph_baseI
finite_pdigraphD(1)[OF assms(1)]
fin_pdg_index_vfinite
)
qed
subsubsection‹
Local assumptions for a finite product semicategory and local
assumptions for an arbitrary product semicategory
›
sublocale finite_psemicategory ⊆ psemicategory α I 𝔄
proof-
interpret finite_pdigraph α I ‹λi. smc_dg (𝔄 i)›
proof(intro finite_pdigraphI pdigraph_baseI)
fix i assume i: "i ∈⇩∘ I"
interpret 𝔄i: semicategory α ‹𝔄 i› by (simp add: i psmc_semicategories)
show "digraph α (smc_dg (𝔄 i))" by (simp add: 𝔄i.smc_digraph)
qed (auto intro!: smc_cs_intros fin_psmc_index_vfinite)
show "psemicategory α I 𝔄"
by (intro psemicategory_pdigraphI)
(simp_all add: psmc_semicategories pdigraph_axioms)
qed
subsection‹Binary union and complement›
lemma (in psemicategory) psmc_smc_prod_vunion_Comp:
assumes "vdisjnt J K"
and "J ⊆⇩∘ I"
and "K ⊆⇩∘ I"
and "g : b ↦⇘(∏⇩S⇩M⇩Cj∈⇩∘J. 𝔄 j)⇙ c"
and "g' : b' ↦⇘(∏⇩S⇩M⇩Ck∈⇩∘K. 𝔄 k)⇙ c'"
and "f : a ↦⇘(∏⇩S⇩M⇩Cj∈⇩∘J. 𝔄 j)⇙ b"
and "f' : a' ↦⇘(∏⇩S⇩M⇩Ck∈⇩∘K. 𝔄 k)⇙ b'"
shows "(g ∘⇩A⇘(∏⇩S⇩M⇩Cj∈⇩∘J. 𝔄 j)⇙ f) ∪⇩∘ (g' ∘⇩A⇘(∏⇩S⇩M⇩Cj∈⇩∘K. 𝔄 j)⇙ f') =
g ∪⇩∘ g' ∘⇩A⇘(∏⇩S⇩M⇩Cj∈⇩∘J ∪⇩∘ K. 𝔄 j)⇙ f ∪⇩∘ f'"
proof-
interpret J𝔄: psemicategory α J 𝔄
using assms(2) by (simp add: psmc_vsubset_index_psemicategory)
interpret K𝔄: psemicategory α K 𝔄
using assms(3) by (simp add: psmc_vsubset_index_psemicategory)
interpret JK𝔄: psemicategory α ‹J ∪⇩∘ K› 𝔄
using assms(2,3) by (simp add: psmc_vsubset_index_psemicategory)
interpret J𝔄': semicategory α ‹smc_prod J 𝔄›
by (rule J𝔄.psmc_semicategory_smc_prod)
interpret K𝔄': semicategory α ‹smc_prod K 𝔄›
by (rule K𝔄.psmc_semicategory_smc_prod)
interpret JK𝔄': semicategory α ‹smc_prod (J ∪⇩∘ K) 𝔄›
by (rule JK𝔄.psmc_semicategory_smc_prod)
note gg' = psmc_smc_prod_vunion_is_arr[OF assms(1-3,4,5)]
and ff' = psmc_smc_prod_vunion_is_arr[OF assms(1-3,6,7)]
note gD = J𝔄.smc_prod_is_arrD[OF assms(4)]
and g'D = K𝔄.smc_prod_is_arrD[OF assms(5)]
and fD = J𝔄.smc_prod_is_arrD[OF assms(6)]
and f'D = K𝔄.smc_prod_is_arrD[OF assms(7)]
from assms(4,6) have gf:
"g ∘⇩A⇘smc_prod J 𝔄⇙ f : a ↦⇘(∏⇩S⇩M⇩Cj∈⇩∘J. 𝔄 j)⇙ c"
by (auto intro: smc_cs_intros)
from assms(5,7) have g'f':
"g' ∘⇩A⇘smc_prod K 𝔄⇙ f' : a' ↦⇘(∏⇩S⇩M⇩Ck∈⇩∘K. 𝔄 k)⇙ c'"
by (auto intro: smc_cs_intros)
from gf have "g ∘⇩A⇘smc_prod J 𝔄⇙ f ∈⇩∘ smc_prod J 𝔄⦇Arr⦈" by auto
from g'f' have "g' ∘⇩A⇘smc_prod K 𝔄⇙ f' ∈⇩∘ smc_prod K 𝔄⦇Arr⦈" by auto
from gg' ff' have gg'_ff':
"g ∪⇩∘ g' ∘⇩A⇘smc_prod (J ∪⇩∘ K) 𝔄⇙ f ∪⇩∘ f' :
a ∪⇩∘ a' ↦⇘smc_prod (J ∪⇩∘ K) 𝔄⇙ c ∪⇩∘ c'"
by (simp add: smc_cs_intros)
show ?thesis
proof(rule smc_prod_Arr_cong[of _ ‹J ∪⇩∘ K› 𝔄])
from gf g'f' assms(1) show
"(g ∘⇩A⇘smc_prod J 𝔄⇙ f) ∪⇩∘ (g' ∘⇩A⇘smc_prod K 𝔄⇙ f') ∈⇩∘
smc_prod (J ∪⇩∘ K) 𝔄⦇Arr⦈"
by (auto intro: smc_prod_vunion_Arr_in_Arr)
from gg'_ff' show
"g ∪⇩∘ g' ∘⇩A⇘smc_prod (J ∪⇩∘ K) 𝔄⇙ f ∪⇩∘ f' ∈⇩∘ smc_prod (J ∪⇩∘ K) 𝔄⦇Arr⦈"
by auto
fix i assume prems: "i ∈⇩∘ J ∪⇩∘ K"
then consider (iJ) ‹i ∈⇩∘ J› | (iK) ‹i ∈⇩∘ K› by auto
then show
"((g ∘⇩A⇘smc_prod J 𝔄⇙ f) ∪⇩∘ (g' ∘⇩A⇘smc_prod K 𝔄⇙ f'))⦇i⦈ =
(g ∪⇩∘ g' ∘⇩A⇘smc_prod (J ∪⇩∘ K) 𝔄⇙ f ∪⇩∘ f')⦇i⦈"
proof cases
case iJ
have [simp]:
"((g ∘⇩A⇘smc_prod J 𝔄⇙ f) ∪⇩∘ (g' ∘⇩A⇘smc_prod K 𝔄⇙ f'))⦇i⦈ =
g⦇i⦈ ∘⇩A⇘𝔄 i⇙ f⦇i⦈"
proof
(
fold smc_prod_Comp_app_component[OF assms(4,6) iJ],
rule vsv_vunion_app_left
)
from gf show "vsv (g ∘⇩A⇘smc_prod J 𝔄⇙ f)" by auto
from g'f' show "vsv (g' ∘⇩A⇘smc_prod K 𝔄⇙ f')" by auto
qed
(
use assms(4-7) in
‹simp_all add: iJ assms(1) smc_prod_Comp_app_vdomain›
)
have gg'_i: "(g ∪⇩∘ g')⦇i⦈ = g⦇i⦈"
by (simp add: iJ assms(1) gD(1,2) g'D(1,2))
have ff'_i: "(f ∪⇩∘ f')⦇i⦈ = f⦇i⦈"
by (simp add: iJ assms(1) fD(1,2) f'D(1,2))
have [simp]:
"(g ∪⇩∘ g' ∘⇩A⇘smc_prod (J ∪⇩∘ K) 𝔄⇙ f ∪⇩∘ f')⦇i⦈ = g⦇i⦈ ∘⇩A⇘𝔄 i⇙ f⦇i⦈"
by (fold gg'_i ff'_i)
(rule smc_prod_Comp_app_component[OF gg' ff' prems])
show ?thesis by simp
next
case iK
have [simp]:
"((g ∘⇩A⇘smc_prod J 𝔄⇙ f) ∪⇩∘ (g' ∘⇩A⇘smc_prod K 𝔄⇙ f'))⦇i⦈ =
g'⦇i⦈ ∘⇩A⇘𝔄 i⇙ f'⦇i⦈"
proof
(
fold smc_prod_Comp_app_component[OF assms(5,7) iK],
rule vsv_vunion_app_right
)
from gf show "vsv (g ∘⇩A⇘smc_prod J 𝔄⇙ f)" by auto
from g'f' show "vsv (g' ∘⇩A⇘smc_prod K 𝔄⇙ f')" by auto
qed
(
use assms(4-7) in
‹simp_all add: iK smc_prod_Comp_app_vdomain assms(1)›
)
have gg'_i: "(g ∪⇩∘ g')⦇i⦈ = g'⦇i⦈"
by (simp add: iK assms(1) gD(1,2) g'D(1,2))
have ff'_i: "(f ∪⇩∘ f')⦇i⦈ = f'⦇i⦈"
by (simp add: iK assms(1) fD(1,2) f'D(1,2))
have [simp]:
"(g ∪⇩∘ g' ∘⇩A⇘smc_prod (J ∪⇩∘ K) 𝔄⇙ f ∪⇩∘ f')⦇i⦈ = g'⦇i⦈ ∘⇩A⇘𝔄 i⇙ f'⦇i⦈"
by (fold gg'_i ff'_i)
(rule smc_prod_Comp_app_component[OF gg' ff' prems])
show ?thesis by simp
qed
qed
qed
lemma (in psemicategory) psmc_smc_prod_vdiff_vunion_Comp:
assumes "J ⊆⇩∘ I"
and "g : b ↦⇘(∏⇩S⇩M⇩Cj∈⇩∘I -⇩∘ J. 𝔄 j)⇙ c"
and "g' : b' ↦⇘(∏⇩S⇩M⇩Ck∈⇩∘J. 𝔄 k)⇙ c'"
and "f : a ↦⇘(∏⇩S⇩M⇩Cj∈⇩∘I -⇩∘ J. 𝔄 j)⇙ b"
and "f' : a' ↦⇘(∏⇩S⇩M⇩Ck∈⇩∘J. 𝔄 k)⇙ b'"
shows "(g ∘⇩A⇘(∏⇩S⇩M⇩Cj∈⇩∘I -⇩∘ J. 𝔄 j)⇙ f) ∪⇩∘ (g' ∘⇩A⇘(∏⇩S⇩M⇩Cj∈⇩∘J. 𝔄 j)⇙ f') =
g ∪⇩∘ g' ∘⇩A⇘(∏⇩S⇩M⇩Cj∈⇩∘I. 𝔄 j)⇙ f ∪⇩∘ f'"
by
(
vdiff_of_vunion'
rule: psmc_smc_prod_vunion_Comp assms: assms(2-5) subset: assms(1)
)
subsection‹Projection›
subsubsection‹Definition and elementary properties›
text‹See Chapter II-3 in \cite{mac_lane_categories_2010}.›
definition smcf_proj :: "V ⇒ (V ⇒ V) ⇒ V ⇒ V" (‹π⇩S⇩M⇩C›)
where "π⇩S⇩M⇩C I 𝔄 i =
[
(λa∈⇩∘(∏⇩∘i∈⇩∘I. 𝔄 i⦇Obj⦈). a⦇i⦈),
(λf∈⇩∘(∏⇩∘i∈⇩∘I. 𝔄 i⦇Arr⦈). f⦇i⦈),
(∏⇩S⇩M⇩Ci∈⇩∘I. 𝔄 i),
𝔄 i
]⇩∘"
text‹Components.›
lemma smcf_proj_components:
shows "(π⇩S⇩M⇩C I 𝔄 i)⦇ObjMap⦈ = (λa∈⇩∘(∏⇩∘i∈⇩∘I. 𝔄 i⦇Obj⦈). a⦇i⦈)"
and "(π⇩S⇩M⇩C I 𝔄 i)⦇ArrMap⦈ = (λf∈⇩∘(∏⇩∘i∈⇩∘I. 𝔄 i⦇Arr⦈). f⦇i⦈)"
and "(π⇩S⇩M⇩C I 𝔄 i)⦇HomDom⦈ = (∏⇩S⇩M⇩Ci∈⇩∘I. 𝔄 i)"
and "(π⇩S⇩M⇩C I 𝔄 i)⦇HomCod⦈ = 𝔄 i"
unfolding smcf_proj_def dghm_field_simps by (simp_all add: nat_omega_simps)
text‹Slicing›
lemma smcf_dghm_smcf_proj[slicing_commute]:
"π⇩D⇩G I (λi. smc_dg (𝔄 i)) i = smcf_dghm (π⇩S⇩M⇩C I 𝔄 i)"
unfolding
smc_dg_def
smcf_dghm_def
smcf_proj_def
dghm_proj_def
smc_prod_def
dg_prod_def
dg_field_simps
dghm_field_simps
by (simp add: nat_omega_simps)
context psemicategory
begin
interpretation pdg: pdigraph α I ‹λi. smc_dg (𝔄 i)› by (rule psmc_pdigraph)
lemmas_with [unfolded slicing_simps slicing_commute]:
smcf_proj_is_dghm = pdg.pdg_dghm_proj_is_dghm
end
subsubsection‹Projection semifunctor is a semifunctor›
lemma (in psemicategory) psmc_smcf_proj_is_semifunctor:
assumes "i ∈⇩∘ I"
shows "π⇩S⇩M⇩C I 𝔄 i : (∏⇩S⇩M⇩Ci∈⇩∘I. 𝔄 i) ↦↦⇩S⇩M⇩C⇘α⇙ 𝔄 i"
proof(intro is_semifunctorI)
show "vfsequence (π⇩S⇩M⇩C I 𝔄 i)"
unfolding smcf_proj_def by (simp add: nat_omega_simps)
show "vcard (π⇩S⇩M⇩C I 𝔄 i) = 4⇩ℕ"
unfolding smcf_proj_def by (simp add: nat_omega_simps)
interpret 𝔄: semicategory α ‹smc_prod I 𝔄›
by (rule psmc_semicategory_smc_prod)
interpret 𝔄i: semicategory α ‹𝔄 i›
using assms by (simp add: smc_prod_cs_intros)
show "π⇩S⇩M⇩C I 𝔄 i⦇ArrMap⦈⦇g ∘⇩A⇘smc_prod I 𝔄⇙ f⦈ =
π⇩S⇩M⇩C I 𝔄 i⦇ArrMap⦈⦇g⦈ ∘⇩A⇘𝔄 i⇙ π⇩S⇩M⇩C I 𝔄 i⦇ArrMap⦈⦇f⦈"
if "g : b ↦⇘smc_prod I 𝔄⇙ c" and "f : a ↦⇘smc_prod I 𝔄⇙ b" for g b c f a
proof-
from that have "g ∘⇩A⇘smc_prod I 𝔄⇙ f : a ↦⇘smc_prod I 𝔄⇙ c"
by (auto simp: smc_cs_intros)
then have "g ∘⇩A⇘smc_prod I 𝔄⇙ f ∈⇩∘ (∏⇩∘i∈⇩∘I. 𝔄 i⦇Arr⦈)"
unfolding smc_prod_components[symmetric] by auto
then have π_gf: "π⇩S⇩M⇩C I 𝔄 i⦇ArrMap⦈⦇g ∘⇩A⇘smc_prod I 𝔄⇙ f⦈ = g⦇i⦈ ∘⇩A⇘𝔄 i⇙ f⦇i⦈"
unfolding smcf_proj_components
by (simp add: smc_prod_Comp_app_component[OF that assms])
from that(1) have g: "g ∈⇩∘ (∏⇩∘i∈⇩∘I. 𝔄 i⦇Arr⦈)"
unfolding smc_prod_components[symmetric] by auto
from that(2) have f: "f ∈⇩∘ (∏⇩∘i∈⇩∘I. 𝔄 i⦇Arr⦈)"
unfolding smc_prod_components[symmetric] by auto
from g f have πg_πf:
"π⇩S⇩M⇩C I 𝔄 i⦇ArrMap⦈⦇g⦈ ∘⇩A⇘𝔄 i⇙ π⇩S⇩M⇩C I 𝔄 i⦇ArrMap⦈⦇f⦈ = g⦇i⦈ ∘⇩A⇘𝔄 i⇙ f⦇i⦈"
unfolding smcf_proj_components by simp
from π_gf πg_πf show ?thesis by simp
qed
qed
(
auto simp:
smc_prod_cs_intros
assms
smcf_proj_components
psmc_semicategory_smc_prod
smcf_proj_is_dghm
)
lemma (in psemicategory) psmc_smcf_proj_is_semifunctor':
assumes "i ∈⇩∘ I" and "ℭ = (∏⇩S⇩M⇩Ci∈⇩∘I. 𝔄 i)" and "𝔇 = 𝔄 i"
shows "π⇩S⇩M⇩C I 𝔄 i : ℭ ↦↦⇩S⇩M⇩C⇘α⇙ 𝔇"
using assms(1) unfolding assms(2,3) by (rule psmc_smcf_proj_is_semifunctor)
lemmas [smc_cs_intros] = psemicategory.psmc_smcf_proj_is_semifunctor'
subsection‹Semicategory product universal property semifunctor›
subsubsection‹Definition and elementary properties›
text‹
The following semifunctor is used in the
proof of the universal property of the product semicategory
later in this work.
›
definition smcf_up :: "V ⇒ (V ⇒ V) ⇒ V ⇒ (V ⇒ V) ⇒ V"
where "smcf_up I 𝔄 ℭ φ =
[
(λa∈⇩∘ℭ⦇Obj⦈. (λi∈⇩∘I. φ i⦇ObjMap⦈⦇a⦈)),
(λf∈⇩∘ℭ⦇Arr⦈. (λi∈⇩∘I. φ i⦇ArrMap⦈⦇f⦈)),
ℭ,
(∏⇩S⇩M⇩Ci∈⇩∘I. 𝔄 i)
]⇩∘"
text‹Components.›
lemma smcf_up_components:
shows "smcf_up I 𝔄 ℭ φ⦇ObjMap⦈ = (λa∈⇩∘ℭ⦇Obj⦈. (λi∈⇩∘I. φ i⦇ObjMap⦈⦇a⦈))"
and "smcf_up I 𝔄 ℭ φ⦇ArrMap⦈ = (λf∈⇩∘ℭ⦇Arr⦈. (λi∈⇩∘I. φ i⦇ArrMap⦈⦇f⦈))"
and "smcf_up I 𝔄 ℭ φ⦇HomDom⦈ = ℭ"
and "smcf_up I 𝔄 ℭ φ⦇HomCod⦈ = (∏⇩S⇩M⇩Ci∈⇩∘I. 𝔄 i)"
unfolding smcf_up_def dghm_field_simps by (simp_all add: nat_omega_simps)
text‹Slicing.›
lemma smcf_dghm_smcf_up[slicing_commute]:
"dghm_up I (λi. smc_dg (𝔄 i)) (smc_dg ℭ) (λi. smcf_dghm (φ i)) =
smcf_dghm (smcf_up I 𝔄 ℭ φ)"
unfolding
smc_dg_def
smcf_dghm_def
smcf_up_def
dghm_up_def
smc_prod_def
dg_prod_def
dg_field_simps
dghm_field_simps
by (simp add: nat_omega_simps)
context
fixes 𝔄 φ :: "V ⇒ V"
and ℭ :: V
begin
lemmas_with
[
where 𝔄=‹λi. smc_dg (𝔄 i)› and φ=‹λi. smcf_dghm (φ i)› and ℭ=‹smc_dg ℭ›,
unfolded slicing_simps slicing_commute
]:
smcf_up_ObjMap_vdomain[smc_cs_simps] = dghm_up_ObjMap_vdomain
and smcf_up_ObjMap_app = dghm_up_ObjMap_app
and smcf_up_ObjMap_app_vdomain[smc_cs_simps] = dghm_up_ObjMap_app_vdomain
and smcf_up_ObjMap_app_component[smc_cs_simps] = dghm_up_ObjMap_app_component
and smcf_up_ArrMap_vdomain[smc_cs_simps] = dghm_up_ArrMap_vdomain
and smcf_up_ArrMap_app = dghm_up_ArrMap_app
and smcf_up_ArrMap_app_vdomain[smc_cs_simps] = dghm_up_ArrMap_app_vdomain
and smcf_up_ArrMap_app_component[smc_cs_simps] = dghm_up_ArrMap_app_component
lemma smcf_up_ObjMap_vrange:
assumes "⋀i. i ∈⇩∘ I ⟹ φ i : ℭ ↦↦⇩S⇩M⇩C⇘α⇙ 𝔄 i"
shows "ℛ⇩∘ (smcf_up I 𝔄 ℭ φ⦇ObjMap⦈) ⊆⇩∘ (∏⇩S⇩M⇩Ci∈⇩∘I. 𝔄 i)⦇Obj⦈"
proof
(
rule dghm_up_ObjMap_vrange
[
where 𝔄=‹λi. smc_dg (𝔄 i)›
and φ=‹λi. smcf_dghm (φ i)›
and ℭ=‹smc_dg ℭ›,
unfolded slicing_simps slicing_commute
]
)
fix i assume "i ∈⇩∘ I"
then interpret is_semifunctor α ℭ ‹𝔄 i› ‹φ i› by (rule assms)
show "smcf_dghm (φ i) : smc_dg ℭ ↦↦⇩D⇩G⇘α⇙ smc_dg (𝔄 i)"
by (rule smcf_is_dghm)
qed
lemma smcf_up_ObjMap_app_vrange:
assumes "a ∈⇩∘ ℭ⦇Obj⦈" and "⋀i. i ∈⇩∘ I ⟹ φ i : ℭ ↦↦⇩S⇩M⇩C⇘α⇙ 𝔄 i"
shows " ℛ⇩∘ (smcf_up I 𝔄 ℭ φ⦇ObjMap⦈⦇a⦈) ⊆⇩∘ (⋃⇩∘i∈⇩∘I. 𝔄 i⦇Obj⦈)"
proof
(
rule dghm_up_ObjMap_app_vrange
[
where 𝔄=‹λi. smc_dg (𝔄 i)›
and φ=‹λi. smcf_dghm (φ i)›
and ℭ=‹smc_dg ℭ›,
unfolded slicing_simps slicing_commute
]
)
show "a ∈⇩∘ ℭ⦇Obj⦈" by (rule assms)
fix i assume "i ∈⇩∘ I"
then interpret is_semifunctor α ℭ ‹𝔄 i› ‹φ i› by (rule assms(2))
show "smcf_dghm (φ i) : smc_dg ℭ ↦↦⇩D⇩G⇘α⇙ smc_dg (𝔄 i)"
by (rule smcf_is_dghm)
qed
lemma smcf_up_ArrMap_vrange:
assumes "⋀i. i ∈⇩∘ I ⟹ φ i : ℭ ↦↦⇩S⇩M⇩C⇘α⇙ 𝔄 i"
shows "ℛ⇩∘ (smcf_up I 𝔄 ℭ φ⦇ArrMap⦈) ⊆⇩∘ (∏⇩S⇩M⇩Ci∈⇩∘I. 𝔄 i)⦇Arr⦈"
proof
(
rule dghm_up_ArrMap_vrange
[
where 𝔄=‹λi. smc_dg (𝔄 i)›
and φ=‹λi. smcf_dghm (φ i)›
and ℭ=‹smc_dg ℭ›,
unfolded slicing_simps slicing_commute
]
)
fix i assume "i ∈⇩∘ I"
then interpret is_semifunctor α ℭ ‹𝔄 i› ‹φ i› by (rule assms)
show "smcf_dghm (φ i) : smc_dg ℭ ↦↦⇩D⇩G⇘α⇙ smc_dg (𝔄 i)"
by (rule smcf_is_dghm)
qed
lemma smcf_up_ArrMap_app_vrange:
assumes "a ∈⇩∘ ℭ⦇Arr⦈" and "⋀i. i ∈⇩∘ I ⟹ φ i : ℭ ↦↦⇩S⇩M⇩C⇘α⇙ 𝔄 i"
shows "ℛ⇩∘ (smcf_up I 𝔄 ℭ φ⦇ArrMap⦈⦇a⦈) ⊆⇩∘ (⋃⇩∘i∈⇩∘I. 𝔄 i⦇Arr⦈)"
proof
(
rule dghm_up_ArrMap_app_vrange[
where 𝔄=‹λi. smc_dg (𝔄 i)›
and φ=‹λi. smcf_dghm (φ i)›
and ℭ=‹smc_dg ℭ›,
unfolded slicing_simps slicing_commute
]
)
show "a ∈⇩∘ ℭ⦇Arr⦈" by (rule assms)
fix i assume "i ∈⇩∘ I"
then interpret is_semifunctor α ℭ ‹𝔄 i› ‹φ i› by (rule assms(2))
show "smcf_dghm (φ i) : smc_dg ℭ ↦↦⇩D⇩G⇘α⇙ smc_dg (𝔄 i)"
by (rule smcf_is_dghm)
qed
end
context psemicategory
begin
interpretation pdg: pdigraph α I ‹λi. smc_dg (𝔄 i)› by (rule psmc_pdigraph)
lemmas_with [unfolded slicing_simps slicing_commute]:
psmc_dghm_comp_dghm_proj_dghm_up = pdg.pdg_dghm_comp_dghm_proj_dghm_up
and psmc_dghm_up_eq_dghm_proj = pdg.pdg_dghm_up_eq_dghm_proj
end
subsubsection‹
Semicategory product universal property semifunctor is a semifunctor
›
lemma (in psemicategory) psmc_smcf_up_is_semifunctor:
assumes "semicategory α ℭ" and "⋀i. i ∈⇩∘ I ⟹ φ i : ℭ ↦↦⇩S⇩M⇩C⇘α⇙ 𝔄 i"
shows "smcf_up I 𝔄 ℭ φ : ℭ ↦↦⇩S⇩M⇩C⇘α⇙ (∏⇩S⇩M⇩Ci∈⇩∘I. 𝔄 i)"
proof(intro is_semifunctorI)
interpret ℭ: semicategory α ℭ by (simp add: assms(1))
interpret 𝔄: semicategory α ‹smc_prod I 𝔄›
by (rule psmc_semicategory_smc_prod)
show "vfsequence (smcf_up I 𝔄 ℭ φ)"
unfolding smcf_up_def by simp
show "vcard (smcf_up I 𝔄 ℭ φ) = 4⇩ℕ"
unfolding smcf_up_def by (simp add: nat_omega_simps)
show dghm_smcf_up:
"smcf_dghm (smcf_up I 𝔄 ℭ φ) : smc_dg ℭ ↦↦⇩D⇩G⇘α⇙ smc_dg (smc_prod I 𝔄)"
by
(
simp add:
assms
slicing_commute[symmetric]
psmc_pdigraph
is_semifunctor.smcf_is_dghm
pdigraph.pdg_dghm_up_is_dghm
semicategory.smc_digraph
)
interpret smcf_up:
is_dghm α ‹smc_dg ℭ› ‹smc_dg (smc_prod I 𝔄)› ‹smcf_dghm (smcf_up I 𝔄 ℭ φ)›
by (rule dghm_smcf_up)
show "smcf_up I 𝔄 ℭ φ⦇ArrMap⦈⦇g ∘⇩A⇘ℭ⇙ f⦈ =
smcf_up I 𝔄 ℭ φ⦇ArrMap⦈⦇g⦈ ∘⇩A⇘smc_prod I 𝔄⇙ smcf_up I 𝔄 ℭ φ⦇ArrMap⦈⦇f⦈"
if "g : b ↦⇘ℭ⇙ c" and "f : a ↦⇘ℭ⇙ b" for g b c f a
proof(rule smc_prod_Arr_cong[of _ I 𝔄])
note smcf_up_f =
smcf_up.dghm_ArrMap_is_arr[unfolded slicing_simps, OF that(2)]
and smcf_up_g =
smcf_up.dghm_ArrMap_is_arr[unfolded slicing_simps, OF that(1)]
from that have gf: "g ∘⇩A⇘ℭ⇙ f : a ↦⇘ℭ⇙ c"
by (simp add: smc_cs_intros)
from smcf_up.dghm_ArrMap_is_arr[unfolded slicing_simps, OF this] show
"smcf_up I 𝔄 ℭ φ⦇ArrMap⦈⦇g ∘⇩A⇘ℭ⇙ f⦈ ∈⇩∘ smc_prod I 𝔄⦇Arr⦈"
by (simp add: smc_cs_intros)
from smcf_up_g smcf_up_f show
"smcf_up I 𝔄 ℭ φ⦇ArrMap⦈⦇g⦈ ∘⇩A⇘smc_prod I 𝔄⇙ smcf_up I 𝔄 ℭ φ⦇ArrMap⦈⦇f⦈ ∈⇩∘
smc_prod I 𝔄⦇Arr⦈"
by (meson 𝔄.smc_is_arrE 𝔄.smc_Comp_is_arr)
fix i assume prems: "i ∈⇩∘ I"
from gf have gf': "g ∘⇩A⇘ℭ⇙ f ∈⇩∘ ℭ⦇Arr⦈" by (simp add: smc_cs_intros)
from that have g: "g ∈⇩∘ ℭ⦇Arr⦈" and f: "f ∈⇩∘ ℭ⦇Arr⦈" by auto
interpret φ: is_semifunctor α ℭ ‹𝔄 i› ‹φ i› by (rule assms(2)[OF prems])
from that show "smcf_up I 𝔄 ℭ φ⦇ArrMap⦈⦇g ∘⇩A⇘ℭ⇙ f⦈⦇i⦈ =
(
smcf_up I 𝔄 ℭ φ⦇ArrMap⦈⦇g⦈ ∘⇩A⇘smc_prod I 𝔄⇙ smcf_up I 𝔄 ℭ φ⦇ArrMap⦈⦇f⦈
)⦇i⦈"
unfolding
smcf_up_ArrMap_app_component[OF gf' prems]
smc_prod_Comp_app_component[OF smcf_up_g smcf_up_f prems]
smcf_up_ArrMap_app_component[OF g prems]
smcf_up_ArrMap_app_component[OF f prems]
by (rule φ.smcf_ArrMap_Comp)
qed
qed (auto simp: assms(1) psmc_semicategory_smc_prod smcf_up_components)
subsubsection‹Further properties›
lemma (in psemicategory) psmc_Comp_smcf_proj_smcf_up:
assumes "semicategory α ℭ"
and "⋀i. i ∈⇩∘ I ⟹ φ i : ℭ ↦↦⇩S⇩M⇩C⇘α⇙ 𝔄 i"
and "i ∈⇩∘ I"
shows "φ i = π⇩S⇩M⇩C I 𝔄 i ∘⇩S⇩M⇩C⇩F smcf_up I 𝔄 ℭ φ"
proof(rule smcf_dghm_eqI)
interpret φ: is_semifunctor α ℭ ‹𝔄 i› ‹φ i› by (rule assms(2)[OF assms(3)])
interpret π: is_semifunctor α ‹smc_prod I 𝔄› ‹𝔄 i› ‹π⇩S⇩M⇩C I 𝔄 i›
by (simp add: assms(3) psmc_smcf_proj_is_semifunctor)
interpret up: is_semifunctor α ℭ ‹smc_prod I 𝔄› ‹smcf_up I 𝔄 ℭ φ›
by
(
simp add:
assms(2) φ.HomDom.semicategory_axioms psmc_smcf_up_is_semifunctor
)
show "φ i : ℭ ↦↦⇩S⇩M⇩C⇘α⇙ 𝔄 i" by (simp add: smc_cs_intros)
show "π⇩S⇩M⇩C I 𝔄 i ∘⇩S⇩M⇩C⇩F smcf_up I 𝔄 ℭ φ : ℭ ↦↦⇩S⇩M⇩C⇘α⇙ 𝔄 i"
by (auto intro: smc_cs_intros)
from assms show
"smcf_dghm (φ i) = smcf_dghm (π⇩S⇩M⇩C I 𝔄 i ∘⇩S⇩M⇩C⇩F smcf_up I 𝔄 ℭ φ)"
unfolding slicing_simps[symmetric] slicing_commute[symmetric]
by
(
intro
psmc_dghm_comp_dghm_proj_dghm_up
[
where φ=‹λi. smcf_dghm (φ i)›,
unfolded slicing_simps[symmetric] slicing_commute[symmetric]
]
)
(auto simp: is_semifunctor.smcf_is_dghm)
qed simp_all
lemma (in psemicategory) psmc_smcf_up_eq_smcf_proj:
assumes "𝔉 : ℭ ↦↦⇩S⇩M⇩C⇘α⇙ (∏⇩S⇩M⇩Ci∈⇩∘I. 𝔄 i)"
and "⋀i. i ∈⇩∘ I ⟹ φ i = π⇩S⇩M⇩C I 𝔄 i ∘⇩S⇩M⇩C⇩F 𝔉"
shows "smcf_up I 𝔄 ℭ φ = 𝔉"
proof(rule smcf_dghm_eqI)
interpret 𝔉: is_semifunctor α ℭ ‹(∏⇩S⇩M⇩Ci∈⇩∘I. 𝔄 i)› 𝔉 by (rule assms(1))
show "smcf_up I 𝔄 ℭ φ : ℭ ↦↦⇩S⇩M⇩C⇘α⇙ (∏⇩S⇩M⇩Ci∈⇩∘I. 𝔄 i)"
proof(rule psmc_smcf_up_is_semifunctor)
fix i assume prems: "i ∈⇩∘ I"
interpret π: is_semifunctor α ‹(∏⇩S⇩M⇩Ci∈⇩∘I. 𝔄 i)› ‹𝔄 i› ‹π⇩S⇩M⇩C I 𝔄 i›
using prems by (rule psmc_smcf_proj_is_semifunctor)
show "φ i : ℭ ↦↦⇩S⇩M⇩C⇘α⇙ 𝔄 i"
unfolding assms(2)[OF prems] by (auto intro: smc_cs_intros)
qed (auto intro: smc_cs_intros)
show "𝔉 : ℭ ↦↦⇩S⇩M⇩C⇘α⇙ (∏⇩S⇩M⇩Ci∈⇩∘I. 𝔄 i)" by (rule assms(1))
from assms show "smcf_dghm (smcf_up I 𝔄 ℭ φ) = smcf_dghm 𝔉"
unfolding slicing_simps[symmetric] slicing_commute[symmetric]
by (intro psmc_dghm_up_eq_dghm_proj)
(auto simp: slicing_simps slicing_commute)
qed simp_all
subsection‹Singleton semicategory›
subsubsection‹Slicing›
context
fixes ℭ :: V
begin
lemmas_with [where ℭ=‹smc_dg ℭ›, unfolded slicing_simps slicing_commute]:
smc_singleton_ObjI = dg_singleton_ObjI
and smc_singleton_ObjE = dg_singleton_ObjE
and smc_singleton_ArrI = dg_singleton_ArrI
and smc_singleton_ArrE = dg_singleton_ArrE
end
context semicategory
begin
interpretation dg: digraph α ‹smc_dg ℭ› by (rule smc_digraph)
lemmas_with [unfolded slicing_simps slicing_commute]:
smc_finite_pdigraph_smc_singleton = dg.dg_finite_pdigraph_dg_singleton
and smc_singleton_is_arrI = dg.dg_singleton_is_arrI
and smc_singleton_is_arrD = dg.dg_singleton_is_arrD
and smc_singleton_is_arrE = dg.dg_singleton_is_arrE
end
subsubsection‹Singleton semicategory is a semicategory›
lemma (in semicategory) smc_finite_psemicategory_smc_singleton:
assumes "j ∈⇩∘ Vset α"
shows "finite_psemicategory α (set {j}) (λi. ℭ)"
by
(
auto intro:
assms
semicategory_axioms
finite_psemicategory_finite_pdigraphI
smc_finite_pdigraph_smc_singleton
)
lemma (in semicategory) smc_semicategory_smc_singleton:
assumes "j ∈⇩∘ Vset α"
shows "semicategory α (∏⇩S⇩M⇩Ci∈⇩∘set {j}. ℭ)"
proof-
interpret finite_psemicategory α ‹set {j}› ‹λi. ℭ›
using assms by (rule smc_finite_psemicategory_smc_singleton)
show ?thesis by (rule psmc_semicategory_smc_prod)
qed
subsection‹Singleton semifunctor›
subsubsection‹Definition and elementary properties›
definition smcf_singleton :: "V ⇒ V ⇒ V"
where "smcf_singleton j ℭ =
[
(λa∈⇩∘ℭ⦇Obj⦈. set {⟨j, a⟩}),
(λf∈⇩∘ℭ⦇Arr⦈. set {⟨j, f⟩}),
ℭ,
(∏⇩S⇩M⇩Ci∈⇩∘set {j}. ℭ)
]⇩∘"
text‹Components.›
lemma smcf_singleton_components:
shows "smcf_singleton j ℭ⦇ObjMap⦈ = (λa∈⇩∘ℭ⦇Obj⦈. set {⟨j, a⟩})"
and "smcf_singleton j ℭ⦇ArrMap⦈ = (λf∈⇩∘ℭ⦇Arr⦈. set {⟨j, f⟩})"
and "smcf_singleton j ℭ⦇HomDom⦈ = ℭ"
and "smcf_singleton j ℭ⦇HomCod⦈ = (∏⇩S⇩M⇩Ci∈⇩∘set {j}. ℭ)"
unfolding smcf_singleton_def dghm_field_simps
by (simp_all add: nat_omega_simps)
text‹Slicing.›
lemma smcf_dghm_smcf_singleton[slicing_commute]:
"dghm_singleton j (smc_dg ℭ)= smcf_dghm (smcf_singleton j ℭ)"
unfolding dghm_singleton_def smcf_singleton_def slicing_simps slicing_commute
by
(
simp add:
nat_omega_simps dghm_field_simps dg_field_simps smc_dg_def smcf_dghm_def
)
context
fixes ℭ :: V
begin
lemmas_with [where ℭ=‹smc_dg ℭ›, unfolded slicing_simps slicing_commute]:
smcf_singleton_ObjMap_vsv[smc_cs_intros] = dghm_singleton_ObjMap_vsv
and smcf_singleton_ObjMap_vdomain[smc_cs_simps] =
dghm_singleton_ObjMap_vdomain
and smcf_singleton_ObjMap_vrange = dghm_singleton_ObjMap_vrange
and smcf_singleton_ObjMap_app[smc_prod_cs_simps] = dghm_singleton_ObjMap_app
and smcf_singleton_ArrMap_vsv[smc_cs_intros] = dghm_singleton_ArrMap_vsv
and smcf_singleton_ArrMap_vdomain[smc_cs_simps] =
dghm_singleton_ArrMap_vdomain
and smcf_singleton_ArrMap_vrange = dghm_singleton_ArrMap_vrange
and smcf_singleton_ArrMap_app[smc_prod_cs_simps] = dghm_singleton_ArrMap_app
end
context semicategory
begin
interpretation dg: digraph α ‹smc_dg ℭ› by (rule smc_digraph)
lemmas_with [unfolded slicing_simps slicing_commute]:
smc_smcf_singleton_is_dghm = dg.dg_dghm_singleton_is_dghm
end
subsubsection‹Singleton semifunctor is an isomorphism of semicategories›
lemma (in semicategory) smc_smcf_singleton_is_iso_semifunctor:
assumes "j ∈⇩∘ Vset α"
shows "smcf_singleton j ℭ : ℭ ↦↦⇩S⇩M⇩C⇩.⇩i⇩s⇩o⇘α⇙ (∏⇩S⇩M⇩Ci∈⇩∘set {j}. ℭ)"
proof(intro is_iso_semifunctorI is_semifunctorI)
show dghm_singleton:
"smcf_dghm (smcf_singleton j ℭ) :
smc_dg ℭ ↦↦⇩D⇩G⇩.⇩i⇩s⇩o⇘α⇙ smc_dg (∏⇩S⇩M⇩Ci∈⇩∘set {j}. ℭ)"
by (rule smc_smcf_singleton_is_dghm[OF assms, unfolded slicing_simps])
show "vfsequence (smcf_singleton j ℭ)" unfolding smcf_singleton_def by simp
show "vcard (smcf_singleton j ℭ) = 4⇩ℕ"
unfolding smcf_singleton_def by (simp add: nat_omega_simps)
from dghm_singleton show
"smcf_dghm (smcf_singleton j ℭ) :
smc_dg ℭ ↦↦⇩D⇩G⇘α⇙ smc_dg (∏⇩S⇩M⇩Ci∈⇩∘set {j}. ℭ)"
by (simp add: is_iso_dghm.axioms(1))
show "smcf_singleton j ℭ⦇ArrMap⦈⦇g ∘⇩A⇘ℭ⇙ f⦈ =
smcf_singleton j ℭ⦇ArrMap⦈⦇g⦈ ∘⇩A⇘∏⇩S⇩M⇩Ci∈⇩∘set {j}. ℭ⇙
smcf_singleton j ℭ⦇ArrMap⦈⦇f⦈"
if "g : b ↦⇘ℭ⇙ c" and "f : a ↦⇘ℭ⇙ b" for g b c f a
proof-
let ?jg = ‹smcf_singleton j ℭ⦇ArrMap⦈⦇g⦈›
and ?jf = ‹smcf_singleton j ℭ⦇ArrMap⦈⦇f⦈›
from that have [simp]: "?jg = set {⟨j, g⟩}" "?jf = set {⟨j, f⟩}"
by (simp_all add: smcf_singleton_ArrMap_app smc_cs_intros)
from that have "g ∘⇩A⇘ℭ⇙ f : a ↦⇘ℭ⇙ c" by (auto intro: smc_cs_intros)
then have "smcf_singleton j ℭ⦇ArrMap⦈⦇g ∘⇩A⇘ℭ⇙ f⦈ = set {⟨j, g ∘⇩A⇘ℭ⇙ f⟩}"
by (simp_all add: smcf_singleton_ArrMap_app smc_cs_intros)
moreover from
smc_singleton_is_arrI[OF assms that(1)]
smc_singleton_is_arrI[OF assms that(2)]
have "?jg ∘⇩A⇘∏⇩S⇩M⇩Ci∈⇩∘set {j}. ℭ⇙ ?jf = set {⟨j, g ∘⇩A⇘ℭ⇙ f⟩}"
by (simp add: smc_prod_Comp_app VLambda_vsingleton)
ultimately show ?thesis by auto
qed
qed
(
auto intro:
smc_cs_intros
assms
smc_semicategory_smc_singleton
smcf_singleton_components
)
lemmas [smc_cs_intros] = semicategory.smc_smcf_singleton_is_iso_semifunctor
subsection‹Product of two semicategories›
subsubsection‹Definition and elementary properties.›
text‹See Chapter II-3 in \cite{mac_lane_categories_2010}.›
definition smc_prod_2 :: "V ⇒ V ⇒ V" (infixr ‹×⇩S⇩M⇩C› 80)
where "𝔄 ×⇩S⇩M⇩C 𝔅 ≡ smc_prod (2⇩ℕ) (λi. (i = 0 ? 𝔄 : 𝔅))"
text‹Slicing.›
lemma smc_dg_smc_prod_2[slicing_commute]:
"smc_dg 𝔄 ×⇩D⇩G smc_dg 𝔅 = smc_dg (𝔄 ×⇩S⇩M⇩C 𝔅)"
unfolding smc_prod_2_def dg_prod_2_def slicing_commute[symmetric] if_distrib
by simp
context
fixes α 𝔄 𝔅
assumes 𝔄: "semicategory α 𝔄" and 𝔅: "semicategory α 𝔅"
begin
interpretation 𝔄: semicategory α 𝔄 by (rule 𝔄)
interpretation 𝔅: semicategory α 𝔅 by (rule 𝔅)
lemmas_with
[
where 𝔄=‹smc_dg 𝔄› and 𝔅=‹smc_dg 𝔅›,
unfolded slicing_simps slicing_commute,
OF 𝔄.smc_digraph 𝔅.smc_digraph
]:
smc_prod_2_ObjI = dg_prod_2_ObjI
and smc_prod_2_ObjI'[smc_prod_cs_intros] = dg_prod_2_ObjI'
and smc_prod_2_ObjE = dg_prod_2_ObjE
and smc_prod_2_ArrI = dg_prod_2_ArrI
and smc_prod_2_ArrI'[smc_prod_cs_intros] = dg_prod_2_ArrI'
and smc_prod_2_ArrE = dg_prod_2_ArrE
and smc_prod_2_is_arrI = dg_prod_2_is_arrI
and smc_prod_2_is_arrI'[smc_prod_cs_intros] = dg_prod_2_is_arrI'
and smc_prod_2_is_arrE = dg_prod_2_is_arrE
and smc_prod_2_Dom_vsv = dg_prod_2_Dom_vsv
and smc_prod_2_Dom_vdomain[smc_cs_simps] = dg_prod_2_Dom_vdomain
and smc_prod_2_Dom_app[smc_prod_cs_simps] = dg_prod_2_Dom_app
and smc_prod_2_Dom_vrange = dg_prod_2_Dom_vrange
and smc_prod_2_Cod_vsv = dg_prod_2_Cod_vsv
and smc_prod_2_Cod_vdomain[smc_cs_simps] = dg_prod_2_Cod_vdomain
and smc_prod_2_Cod_app[smc_prod_cs_simps] = dg_prod_2_Cod_app
and smc_prod_2_Cod_vrange = dg_prod_2_Cod_vrange
and smc_prod_2_op_smc_smc_Obj[smc_op_simps] = dg_prod_2_op_dg_dg_Obj
and smc_prod_2_smc_op_smc_Obj[smc_op_simps] = dg_prod_2_dg_op_dg_Obj
and smc_prod_2_op_smc_smc_Arr[smc_op_simps] = dg_prod_2_op_dg_dg_Arr
and smc_prod_2_smc_op_smc_Arr[smc_op_simps] = dg_prod_2_dg_op_dg_Arr
end
subsubsection‹Product of two semicategories is a semicategory›
context
fixes α 𝔄 𝔅
assumes 𝔄: "semicategory α 𝔄" and 𝔅: "semicategory α 𝔅"
begin
interpretation 𝒵 α by (rule semicategoryD[OF 𝔄])
interpretation 𝔄: semicategory α 𝔄 by (rule 𝔄)
interpretation 𝔅: semicategory α 𝔅 by (rule 𝔅)
lemma finite_psemicategory_smc_prod_2:
"finite_psemicategory α (2⇩ℕ) (if2 𝔄 𝔅)"
proof(intro finite_psemicategoryI psemicategory_baseI)
from Axiom_of_Infinity show z1_in_Vset: "2⇩ℕ ∈⇩∘ Vset α" by blast
show "semicategory α (i = 0 ? 𝔄 : 𝔅)" if "i ∈⇩∘ 2⇩ℕ" for i
by (auto simp: smc_cs_intros)
qed auto
interpretation finite_psemicategory α ‹2⇩ℕ› ‹if2 𝔄 𝔅›
by (intro finite_psemicategory_smc_prod_2 𝔄 𝔅)
lemma semicategory_smc_prod_2[smc_cs_intros]: "semicategory α (𝔄 ×⇩S⇩M⇩C 𝔅)"
unfolding smc_prod_2_def by (rule psmc_semicategory_smc_prod)
end
subsubsection‹Composition›
context
fixes α 𝔄 𝔅
assumes 𝔄: "semicategory α 𝔄" and 𝔅: "semicategory α 𝔅"
begin
interpretation 𝒵 α by (rule semicategoryD[OF 𝔄])
interpretation finite_psemicategory α ‹2⇩ℕ› ‹if2 𝔄 𝔅›
by (intro finite_psemicategory_smc_prod_2 𝔄 𝔅)
lemma smc_prod_2_Comp_app[smc_prod_cs_simps]:
assumes "[g, g']⇩∘ : [b, b']⇩∘ ↦⇘𝔄 ×⇩S⇩M⇩C 𝔅⇙ [c, c']⇩∘"
and "[f, f']⇩∘ : [a, a']⇩∘ ↦⇘𝔄 ×⇩S⇩M⇩C 𝔅⇙ [b, b']⇩∘"
shows "[g, g']⇩∘ ∘⇩A⇘𝔄 ×⇩S⇩M⇩C 𝔅⇙ [f, f']⇩∘ = [g ∘⇩A⇘𝔄⇙ f, g' ∘⇩A⇘𝔅⇙ f']⇩∘"
proof-
have "[g, g']⇩∘ ∘⇩A⇘𝔄 ×⇩S⇩M⇩C 𝔅⇙ [f, f']⇩∘ =
(λi∈⇩∘2⇩ℕ. [g, g']⇩∘⦇i⦈ ∘⇩A⇘i = 0 ? 𝔄 : 𝔅⇙ [f, f']⇩∘⦇i⦈)"
by
(
rule smc_prod_Comp_app[
OF assms[unfolded smc_prod_2_def], folded smc_prod_2_def
]
)
also have
"(λi∈⇩∘2⇩ℕ. [g, g']⇩∘⦇i⦈ ∘⇩A⇘i = 0 ? 𝔄 : 𝔅⇙ [f, f']⇩∘⦇i⦈) =
[g ∘⇩A⇘𝔄⇙ f, g' ∘⇩A⇘𝔅⇙ f']⇩∘"
proof(rule vsv_eqI, unfold vdomain_VLambda)
fix i assume "i ∈⇩∘ 2⇩ℕ"
then consider ‹i = 0› | ‹i = 1⇩ℕ› unfolding two by auto
then show
"(λi∈⇩∘2⇩ℕ. [g, g']⇩∘⦇i⦈ ∘⇩A⇘i = 0 ? 𝔄 : 𝔅⇙ [f, f']⇩∘⦇i⦈)⦇i⦈ =
[g ∘⇩A⇘𝔄⇙ f, g' ∘⇩A⇘𝔅⇙ f']⇩∘⦇i⦈"
by cases (simp_all add: two nat_omega_simps)
qed (auto simp: two nat_omega_simps)
finally show ?thesis by simp
qed
end
subsubsection‹Opposite product semicategory›
context
fixes α 𝔄 𝔅
assumes 𝔄: "semicategory α 𝔄" and 𝔅: "semicategory α 𝔅"
begin
interpretation 𝔄: semicategory α 𝔄 by (rule 𝔄)
interpretation 𝔅: semicategory α 𝔅 by (rule 𝔅)
lemma op_smc_smc_prod_2[smc_op_simps]:
"op_smc (𝔄 ×⇩S⇩M⇩C 𝔅) = op_smc 𝔄 ×⇩S⇩M⇩C op_smc 𝔅"
proof(rule smc_dg_eqI[of α])
from 𝔄 𝔅 show smc_lhs: "semicategory α (op_smc (𝔄 ×⇩S⇩M⇩C 𝔅))"
by
(
cs_concl
cs_simp: smc_cs_simps smc_op_simps
cs_intro: smc_cs_intros smc_op_intros
)
interpret smc_lhs: semicategory α ‹op_smc (𝔄 ×⇩S⇩M⇩C 𝔅)› by (rule smc_lhs)
from 𝔄 𝔅 show smc_rhs: "semicategory α (op_smc 𝔄 ×⇩S⇩M⇩C op_smc 𝔅)"
by
(
cs_concl
cs_simp: smc_cs_simps smc_op_simps
cs_intro: smc_cs_intros smc_op_intros
)
interpret smc_rhs: semicategory α ‹op_smc 𝔄 ×⇩S⇩M⇩C op_smc 𝔅› by (rule smc_rhs)
show "op_smc (𝔄 ×⇩S⇩M⇩C 𝔅)⦇Comp⦈ = (op_smc 𝔄 ×⇩S⇩M⇩C op_smc 𝔅)⦇Comp⦈"
proof(rule vsv_eqI)
show "vsv (op_smc (𝔄 ×⇩S⇩M⇩C 𝔅)⦇Comp⦈)"
unfolding op_smc_components by (rule fflip_vsv)
show "vsv ((op_smc 𝔄 ×⇩S⇩M⇩C op_smc 𝔅)⦇Comp⦈)"
unfolding smc_prod_2_def smc_prod_components by simp
show "𝒟⇩∘ (op_smc (𝔄 ×⇩S⇩M⇩C 𝔅)⦇Comp⦈) = 𝒟⇩∘ ((op_smc 𝔄 ×⇩S⇩M⇩C op_smc 𝔅)⦇Comp⦈)"
proof(intro vsubset_antisym vsubsetI)
fix gg'ff' assume gf: "gg'ff' ∈⇩∘ 𝒟⇩∘ (op_smc (𝔄 ×⇩S⇩M⇩C 𝔅)⦇Comp⦈)"
then obtain gg' ff' aa' bb' cc'
where gg'ff'_def: "gg'ff' = [gg', ff']⇩∘"
and "gg' : bb' ↦⇘op_smc (𝔄 ×⇩S⇩M⇩C 𝔅)⇙ cc'"
and "ff' : aa' ↦⇘op_smc (𝔄 ×⇩S⇩M⇩C 𝔅)⇙ bb'"
by clarsimp
then have gg': "gg' : cc' ↦⇘𝔄 ×⇩S⇩M⇩C 𝔅⇙ bb'"
and ff': "ff' : bb' ↦⇘𝔄 ×⇩S⇩M⇩C 𝔅⇙ aa'"
unfolding smc_op_simps by simp_all
from gg' obtain g g' b b' c c'
where gg'_def: "gg' = [g, g']⇩∘"
and "cc' = [c, c']⇩∘"
and "bb' = [b, b']⇩∘"
and g: "g : c ↦⇘𝔄⇙ b"
and g': "g' : c' ↦⇘𝔅⇙ b'"
by (elim smc_prod_2_is_arrE[OF 𝔄 𝔅])
with ff' obtain f f' a a'
where ff'_def: "ff' = [f, f']⇩∘"
and "bb' = [b, b']⇩∘"
and "aa' = [a, a']⇩∘"
and f: "f : b ↦⇘𝔄⇙ a"
and f': "f' : b' ↦⇘𝔅⇙ a'"
by (auto elim: smc_prod_2_is_arrE[OF 𝔄 𝔅])
from 𝔄 𝔅 g g' f f' show "gg'ff' ∈⇩∘ 𝒟⇩∘ ((op_smc 𝔄 ×⇩S⇩M⇩C op_smc 𝔅)⦇Comp⦈)"
by
(
intro smc_rhs.smc_Comp_vdomainI[OF _ _ gg'ff'_def],
unfold gg'_def ff'_def
)
(
cs_concl
cs_simp: smc_cs_simps smc_op_simps
cs_intro: smc_op_intros smc_prod_cs_intros
)
next
fix gg'ff' assume gf: "gg'ff' ∈⇩∘ 𝒟⇩∘ ((op_smc 𝔄 ×⇩S⇩M⇩C op_smc 𝔅)⦇Comp⦈)"
then obtain gg' ff' aa' bb' cc'
where gg'ff'_def: "gg'ff' = [gg', ff']⇩∘"
and gg': "gg' : bb' ↦⇘op_smc 𝔄 ×⇩S⇩M⇩C op_smc 𝔅⇙ cc'"
and ff': "ff' : aa' ↦⇘op_smc 𝔄 ×⇩S⇩M⇩C op_smc 𝔅⇙ bb'"
by clarsimp
from gg' obtain g g' b b' c c'
where gg'_def: "gg' = [g, g']⇩∘"
and "bb' = [b, b']⇩∘"
and "cc' = [c, c']⇩∘"
and g: "g : b ↦⇘op_smc 𝔄⇙ c"
and g': "g' : b' ↦⇘op_smc 𝔅⇙ c'"
by (elim smc_prod_2_is_arrE[OF 𝔄.semicategory_op 𝔅.semicategory_op])
with ff' obtain f f' a a'
where ff'_def: "ff' = [f, f']⇩∘"
and "aa' = [a, a']⇩∘"
and "bb' = [b, b']⇩∘"
and f: "f : a ↦⇘op_smc 𝔄⇙ b"
and f': "f' : a' ↦⇘op_smc 𝔅⇙ b'"
by
(
auto elim:
smc_prod_2_is_arrE[OF 𝔄.semicategory_op 𝔅.semicategory_op]
)
from 𝔄 𝔅 g g' f f' show "gg'ff' ∈⇩∘ 𝒟⇩∘ (op_smc (𝔄 ×⇩S⇩M⇩C 𝔅)⦇Comp⦈)"
by
(
intro smc_lhs.smc_Comp_vdomainI[OF _ _ gg'ff'_def],
unfold gg'_def ff'_def smc_op_simps
)
(
cs_concl
cs_simp: smc_cs_simps smc_op_simps
cs_intro: smc_op_intros smc_prod_cs_intros
)
qed
fix gg'ff' assume "gg'ff' ∈⇩∘ 𝒟⇩∘ (op_smc (𝔄 ×⇩S⇩M⇩C 𝔅)⦇Comp⦈)"
then obtain gg' ff' aa' bb' cc'
where gg'ff'_def: "gg'ff' = [gg', ff']⇩∘"
and "gg' : bb' ↦⇘op_smc (𝔄 ×⇩S⇩M⇩C 𝔅)⇙ cc'"
and "ff' : aa' ↦⇘op_smc (𝔄 ×⇩S⇩M⇩C 𝔅)⇙ bb'"
by clarsimp
then have gg': "gg' : cc' ↦⇘𝔄 ×⇩S⇩M⇩C 𝔅⇙ bb'"
and ff': "ff' : bb' ↦⇘𝔄 ×⇩S⇩M⇩C 𝔅⇙ aa'"
unfolding smc_op_simps by simp_all
from gg' obtain g g' b b' c c'
where gg'_def[smc_cs_simps]: "gg' = [g, g']⇩∘"
and "cc' = [c, c']⇩∘"
and "bb' = [b, b']⇩∘"
and g: "g : c ↦⇘𝔄⇙ b"
and g': "g' : c' ↦⇘𝔅⇙ b'"
by (elim smc_prod_2_is_arrE[OF 𝔄 𝔅])
with ff' obtain f f' a a'
where ff'_def[smc_cs_simps]: "ff' = [f, f']⇩∘"
and "bb' = [b, b']⇩∘"
and "aa' = [a, a']⇩∘"
and f: "f : b ↦⇘𝔄⇙ a"
and f': "f' : b' ↦⇘𝔅⇙ a'"
by (auto elim: smc_prod_2_is_arrE[OF 𝔄 𝔅])
from 𝔄 𝔅 g g' f f' show "op_smc (𝔄 ×⇩S⇩M⇩C 𝔅)⦇Comp⦈⦇gg'ff'⦈ =
(op_smc 𝔄 ×⇩S⇩M⇩C op_smc 𝔅)⦇Comp⦈⦇gg'ff'⦈"
unfolding gg'ff'_def
by
(
cs_concl
cs_simp: smc_cs_simps smc_op_simps smc_prod_cs_simps
cs_intro: smc_cs_intros smc_op_intros smc_prod_cs_intros
)
qed
from 𝔄 𝔅 show
"smc_dg (op_smc (𝔄 ×⇩S⇩M⇩C 𝔅)) = smc_dg (op_smc 𝔄 ×⇩S⇩M⇩C op_smc 𝔅)"
unfolding slicing_commute[symmetric]
by (cs_concl cs_simp: dg_op_simps cs_intro: slicing_intros)
qed
end
subsection‹Projections for the product of two semicategories›
subsubsection‹Definition and elementary properties›
text‹See Chapter II-3 in \cite{mac_lane_categories_2010}.›
definition smcf_proj_fst :: "V ⇒ V ⇒ V" (‹π⇩S⇩M⇩C⇩.⇩1›)
where "π⇩S⇩M⇩C⇩.⇩1 𝔄 𝔅 = smcf_proj (2⇩ℕ) (λi. (i = 0 ? 𝔄 : 𝔅)) 0"
definition smcf_proj_snd :: "V ⇒ V ⇒ V" (‹π⇩S⇩M⇩C⇩.⇩2›)
where "π⇩S⇩M⇩C⇩.⇩2 𝔄 𝔅 = smcf_proj (2⇩ℕ) (λi. (i = 0 ? 𝔄 : 𝔅)) (1⇩ℕ)"
text‹Slicing›
lemma smcf_dghm_smcf_proj_fst[slicing_commute]:
"π⇩D⇩G⇩.⇩1 (smc_dg 𝔄) (smc_dg 𝔅) = smcf_dghm (π⇩S⇩M⇩C⇩.⇩1 𝔄 𝔅)"
unfolding
smcf_proj_fst_def dghm_proj_fst_def slicing_commute[symmetric] if_distrib
..
lemma smcf_dghm_smcf_proj_snd[slicing_commute]:
"π⇩D⇩G⇩.⇩2 (smc_dg 𝔄) (smc_dg 𝔅) = smcf_dghm (π⇩S⇩M⇩C⇩.⇩2 𝔄 𝔅)"
unfolding
smcf_proj_snd_def dghm_proj_snd_def slicing_commute[symmetric] if_distrib
..
context
fixes α 𝔄 𝔅
assumes 𝔄: "semicategory α 𝔄" and 𝔅: "semicategory α 𝔅"
begin
interpretation 𝒵 α by (rule semicategoryD[OF 𝔄])
interpretation 𝔄: semicategory α 𝔄 by (rule 𝔄)
interpretation 𝔅: semicategory α 𝔅 by (rule 𝔅)
lemmas_with
[
where 𝔄=‹smc_dg 𝔄› and 𝔅=‹smc_dg 𝔅›,
unfolded slicing_simps slicing_commute,
OF 𝔄.smc_digraph 𝔅.smc_digraph
]:
smcf_proj_fst_ObjMap_app[smc_cs_simps] = dghm_proj_fst_ObjMap_app
and smcf_proj_snd_ObjMap_app[smc_cs_simps] = dghm_proj_snd_ObjMap_app
and smcf_proj_fst_ArrMap_app[smc_cs_simps] = dghm_proj_fst_ArrMap_app
and smcf_proj_snd_ArrMap_app[smc_cs_simps] = dghm_proj_snd_ArrMap_app
end
subsubsection‹
Domain and codomain of a projection of a product of two semicategories
›
lemma smcf_proj_fst_HomDom: "π⇩S⇩M⇩C⇩.⇩1 𝔄 𝔅⦇HomDom⦈ = 𝔄 ×⇩S⇩M⇩C 𝔅"
unfolding smcf_proj_fst_def smcf_proj_components smc_prod_2_def ..
lemma smcf_proj_fst_HomCod: "π⇩S⇩M⇩C⇩.⇩1 𝔄 𝔅⦇HomCod⦈ = 𝔄"
unfolding smcf_proj_fst_def smcf_proj_components smc_prod_2_def by simp
lemma smcf_proj_snd_HomDom: "π⇩S⇩M⇩C⇩.⇩2 𝔄 𝔅⦇HomDom⦈ = 𝔄 ×⇩S⇩M⇩C 𝔅"
unfolding smcf_proj_snd_def smcf_proj_components smc_prod_2_def ..
lemma smcf_proj_snd_HomCod: "π⇩S⇩M⇩C⇩.⇩2 𝔄 𝔅⦇HomCod⦈ = 𝔅"
unfolding smcf_proj_snd_def smcf_proj_components smc_prod_2_def by simp
subsubsection‹Projection of a product of two semicategories is a semifunctor›
context
fixes α 𝔄 𝔅
assumes 𝔄: "semicategory α 𝔄" and 𝔅: "semicategory α 𝔅"
begin
interpretation 𝒵 α by (rule semicategoryD[OF 𝔄])
interpretation finite_psemicategory α ‹2⇩ℕ› ‹if2 𝔄 𝔅›
by (intro finite_psemicategory_smc_prod_2 𝔄 𝔅)
lemma smcf_proj_fst_is_semifunctor:
assumes "i ∈⇩∘ I"
shows "π⇩S⇩M⇩C⇩.⇩1 𝔄 𝔅 : 𝔄 ×⇩S⇩M⇩C 𝔅 ↦↦⇩S⇩M⇩C⇘α⇙ 𝔄"
by
(
rule
psmc_smcf_proj_is_semifunctor[
where i=0, simplified, folded smcf_proj_fst_def smc_prod_2_def
]
)
lemma smcf_proj_fst_is_semifunctor'[smc_cs_intros]:
assumes "i ∈⇩∘ I" and "ℭ = 𝔄 ×⇩S⇩M⇩C 𝔅" and "𝔇 = 𝔄"
shows "π⇩S⇩M⇩C⇩.⇩1 𝔄 𝔅 : ℭ ↦↦⇩S⇩M⇩C⇘α⇙ 𝔇"
using assms(1) unfolding assms(2,3) by (rule smcf_proj_fst_is_semifunctor)
lemma smcf_proj_snd_is_semifunctor:
assumes "i ∈⇩∘ I"
shows "π⇩S⇩M⇩C⇩.⇩2 𝔄 𝔅 : 𝔄 ×⇩S⇩M⇩C 𝔅 ↦↦⇩S⇩M⇩C⇘α⇙ 𝔅"
by
(
rule
psmc_smcf_proj_is_semifunctor[
where i=‹1⇩ℕ›, simplified, folded smcf_proj_snd_def smc_prod_2_def
]
)
lemma smcf_proj_snd_is_semifunctor'[smc_cs_intros]:
assumes "i ∈⇩∘ I" and "ℭ = 𝔄 ×⇩S⇩M⇩C 𝔅" and "𝔇 = 𝔅"
shows "π⇩S⇩M⇩C⇩.⇩2 𝔄 𝔅 : ℭ ↦↦⇩S⇩M⇩C⇘α⇙ 𝔇"
using assms(1) unfolding assms(2,3) by (rule smcf_proj_snd_is_semifunctor)
end
subsection‹Product of three semicategories›
subsubsection‹Definition and elementary properties.›
definition smc_prod_3 :: "V ⇒ V ⇒ V ⇒ V"
("(_ ×⇩S⇩M⇩C⇩3 _ ×⇩S⇩M⇩C⇩3 _)" [81, 81, 81] 80)
where "𝔄 ×⇩S⇩M⇩C⇩3 𝔅 ×⇩S⇩M⇩C⇩3 ℭ = (∏⇩S⇩M⇩Ci∈⇩∘3⇩ℕ. if3 𝔄 𝔅 ℭ i)"
text‹Slicing.›
lemma smc_dg_smc_prod_3[slicing_commute]:
"smc_dg 𝔄 ×⇩D⇩G⇩3 smc_dg 𝔅 ×⇩D⇩G⇩3 smc_dg ℭ = smc_dg (𝔄 ×⇩S⇩M⇩C⇩3 𝔅 ×⇩S⇩M⇩C⇩3 ℭ)"
unfolding smc_prod_3_def dg_prod_3_def slicing_commute[symmetric] if_distrib
by (simp add: if_distrib[symmetric])
context
fixes α 𝔄 𝔅 ℭ
assumes 𝔄: "semicategory α 𝔄"
and 𝔅: "semicategory α 𝔅"
and ℭ: "semicategory α ℭ"
begin
interpretation 𝔄: semicategory α 𝔄 by (rule 𝔄)
interpretation 𝔅: semicategory α 𝔅 by (rule 𝔅)
interpretation ℭ: semicategory α ℭ by (rule ℭ)
lemmas_with
[
where 𝔄=‹smc_dg 𝔄› and 𝔅=‹smc_dg 𝔅› and ℭ=‹smc_dg ℭ›,
unfolded slicing_simps slicing_commute,
OF 𝔄.smc_digraph 𝔅.smc_digraph ℭ.smc_digraph
]:
smc_prod_3_ObjI = dg_prod_3_ObjI
and smc_prod_3_ObjI'[smc_prod_cs_intros] = dg_prod_3_ObjI'
and smc_prod_3_ObjE = dg_prod_3_ObjE
and smc_prod_3_ArrI = dg_prod_3_ArrI
and smc_prod_3_ArrI'[smc_prod_cs_intros] = dg_prod_3_ArrI'
and smc_prod_3_ArrE = dg_prod_3_ArrE
and smc_prod_3_is_arrI = dg_prod_3_is_arrI
and smc_prod_3_is_arrI'[smc_prod_cs_intros] = dg_prod_3_is_arrI'
and smc_prod_3_is_arrE = dg_prod_3_is_arrE
and smc_prod_3_Dom_vsv = dg_prod_3_Dom_vsv
and smc_prod_3_Dom_vdomain[smc_cs_simps] = dg_prod_3_Dom_vdomain
and smc_prod_3_Dom_app[smc_prod_cs_simps] = dg_prod_3_Dom_app
and smc_prod_3_Dom_vrange = dg_prod_3_Dom_vrange
and smc_prod_3_Cod_vsv = dg_prod_3_Cod_vsv
and smc_prod_3_Cod_vdomain[smc_cs_simps] = dg_prod_3_Cod_vdomain
and smc_prod_3_Cod_app[smc_prod_cs_simps] = dg_prod_3_Cod_app
and smc_prod_3_Cod_vrange = dg_prod_3_Cod_vrange
end
subsubsection‹Product of three semicategories is a semicategory›
context
fixes α 𝔄 𝔅 ℭ
assumes 𝔄: "semicategory α 𝔄"
and 𝔅: "semicategory α 𝔅"
and ℭ: "semicategory α ℭ"
begin
interpretation 𝒵 α by (rule semicategoryD[OF 𝔄])
interpretation 𝔄: semicategory α 𝔄 by (rule 𝔄)
interpretation 𝔅: semicategory α 𝔅 by (rule 𝔅)
interpretation ℭ: semicategory α ℭ by (rule ℭ)
lemma finite_psemicategory_smc_prod_3:
"finite_psemicategory α (3⇩ℕ) (if3 𝔄 𝔅 ℭ)"
proof(intro finite_psemicategoryI psemicategory_baseI)
from Axiom_of_Infinity show z1_in_Vset: "3⇩ℕ ∈⇩∘ Vset α" by blast
show "semicategory α (if3 𝔄 𝔅 ℭ i)" if "i ∈⇩∘ 3⇩ℕ" for i
by (auto simp: smc_cs_intros)
qed auto
interpretation finite_psemicategory α ‹3⇩ℕ› ‹if3 𝔄 𝔅 ℭ›
by (intro finite_psemicategory_smc_prod_3 𝔄 𝔅)
lemma semicategory_smc_prod_3[smc_cs_intros]:
"semicategory α (𝔄 ×⇩S⇩M⇩C⇩3 𝔅 ×⇩S⇩M⇩C⇩3 ℭ)"
unfolding smc_prod_3_def by (rule psmc_semicategory_smc_prod)
end
subsubsection‹Composition›
context
fixes α 𝔄 𝔅 ℭ
assumes 𝔄: "semicategory α 𝔄"
and 𝔅: "semicategory α 𝔅"
and ℭ: "semicategory α ℭ"
begin
interpretation 𝒵 α by (rule semicategoryD[OF 𝔄])
interpretation finite_psemicategory α ‹3⇩ℕ› ‹if3 𝔄 𝔅 ℭ›
by (intro finite_psemicategory_smc_prod_3 𝔄 𝔅 ℭ)
lemma smc_prod_3_Comp_app[smc_prod_cs_simps]:
assumes "[g, g', g'']⇩∘ : [b, b', b'']⇩∘ ↦⇘𝔄 ×⇩S⇩M⇩C⇩3 𝔅 ×⇩S⇩M⇩C⇩3 ℭ⇙ [c, c', c'']⇩∘"
and "[f, f', f'']⇩∘ : [a, a', a'']⇩∘ ↦⇘𝔄 ×⇩S⇩M⇩C⇩3 𝔅 ×⇩S⇩M⇩C⇩3 ℭ⇙ [b, b', b'']⇩∘"
shows
"[g, g', g'']⇩∘ ∘⇩A⇘𝔄 ×⇩S⇩M⇩C⇩3 𝔅 ×⇩S⇩M⇩C⇩3 ℭ⇙ [f, f', f'']⇩∘ =
[g ∘⇩A⇘𝔄⇙ f, g' ∘⇩A⇘𝔅⇙ f', g'' ∘⇩A⇘ℭ⇙ f'']⇩∘"
proof-
have
"[g, g', g'']⇩∘ ∘⇩A⇘𝔄 ×⇩S⇩M⇩C⇩3 𝔅 ×⇩S⇩M⇩C⇩3 ℭ⇙ [f, f', f'']⇩∘ =
(λi∈⇩∘3⇩ℕ. [g, g', g'']⇩∘⦇i⦈ ∘⇩A⇘if3 𝔄 𝔅 ℭ i⇙ [f, f', f'']⇩∘⦇i⦈)"
by
(
rule smc_prod_Comp_app[
OF assms[unfolded smc_prod_3_def], folded smc_prod_3_def
]
)
also have
"(λi∈⇩∘3⇩ℕ. [g, g', g'']⇩∘⦇i⦈ ∘⇩A⇘if3 𝔄 𝔅 ℭ i⇙ [f, f', f'']⇩∘⦇i⦈) =
[g ∘⇩A⇘𝔄⇙ f, g' ∘⇩A⇘𝔅⇙ f', g'' ∘⇩A⇘ℭ⇙ f'']⇩∘"
proof(rule vsv_eqI, unfold vdomain_VLambda)
fix i assume "i ∈⇩∘ 3⇩ℕ"
then consider ‹i = 0› | ‹i = 1⇩ℕ› | ‹i = 2⇩ℕ› unfolding three by auto
then show
"(λi∈⇩∘3⇩ℕ. [g, g', g'']⇩∘⦇i⦈ ∘⇩A⇘if3 𝔄 𝔅 ℭ i⇙ [f, f', f'']⇩∘⦇i⦈)⦇i⦈ =
[g ∘⇩A⇘𝔄⇙ f, g' ∘⇩A⇘𝔅⇙ f', g'' ∘⇩A⇘ℭ⇙ f'']⇩∘⦇i⦈"
by cases (simp_all add: three nat_omega_simps)
qed (auto simp: three nat_omega_simps)
finally show ?thesis by simp
qed
end
text‹\newpage›
end
Theory CZH_SMC_Subsemicategory
section‹Subsemicategory›
theory CZH_SMC_Subsemicategory
imports
CZH_DG_Subdigraph
CZH_SMC_Semifunctor
begin
subsection‹Background›
named_theorems smc_sub_cs_intros
named_theorems smc_sub_bw_cs_intros
named_theorems smc_sub_fw_cs_intros
named_theorems smc_sub_bw_cs_simps
subsection‹Simple subsemicategory›
subsubsection‹Definition and elementary properties›
text‹See Chapter I-3 in \cite{mac_lane_categories_2010}.›
locale subsemicategory =
sdg: semicategory α 𝔅 + dg: semicategory α ℭ for α 𝔅 ℭ +
assumes subsmc_subdigraph[slicing_intros]: "smc_dg 𝔅 ⊆⇩D⇩G⇘α⇙ smc_dg ℭ"
and subsmc_Comp[smc_sub_fw_cs_intros]:
"⟦ g : b ↦⇘𝔅⇙ c; f : a ↦⇘𝔅⇙ b ⟧ ⟹ g ∘⇩A⇘𝔅⇙ f = g ∘⇩A⇘ℭ⇙ f"
abbreviation is_subsemicategory ("(_/ ⊆⇩S⇩M⇩Cı _)" [51, 51] 50)
where "𝔅 ⊆⇩S⇩M⇩C⇘α⇙ ℭ ≡ subsemicategory α 𝔅 ℭ"
lemmas [smc_sub_fw_cs_intros] = subsemicategory.subsmc_Comp
text‹Rules.›
lemma (in subsemicategory) subsemicategory_axioms'[smc_cs_intros]:
assumes "α' = α" and "𝔅' = 𝔅"
shows "𝔅' ⊆⇩S⇩M⇩C⇘α'⇙ ℭ"
unfolding assms by (rule subsemicategory_axioms)
lemma (in subsemicategory) subsemicategory_axioms''[smc_cs_intros]:
assumes "α' = α" and "ℭ' = ℭ"
shows "𝔅 ⊆⇩S⇩M⇩C⇘α'⇙ ℭ'"
unfolding assms by (rule subsemicategory_axioms)
mk_ide rf subsemicategory_def[unfolded subsemicategory_axioms_def]
|intro subsemicategoryI|
|dest subsemicategoryD[dest]|
|elim subsemicategoryE[elim!]|
lemmas [smc_sub_cs_intros] = subsemicategoryD(1,2)
lemma subsemicategoryI':
assumes "semicategory α 𝔅"
and "semicategory α ℭ"
and "⋀a. a ∈⇩∘ 𝔅⦇Obj⦈ ⟹ a ∈⇩∘ ℭ⦇Obj⦈"
and "⋀a b f. f : a ↦⇘𝔅⇙ b ⟹ f : a ↦⇘ℭ⇙ b"
and "⋀b c g a f. ⟦ g : b ↦⇘𝔅⇙ c; f : a ↦⇘𝔅⇙ b ⟧ ⟹
g ∘⇩A⇘𝔅⇙ f = g ∘⇩A⇘ℭ⇙ f"
shows "𝔅 ⊆⇩S⇩M⇩C⇘α⇙ ℭ"
proof-
interpret 𝔅: semicategory α 𝔅 by (rule assms(1))
interpret ℭ: semicategory α ℭ by (rule assms(2))
show ?thesis
by
(
intro subsemicategoryI subdigraphI,
unfold slicing_simps;
(intro 𝔅.smc_digraph ℭ.smc_digraph assms)?
)
qed
text‹Subsemicategory is a subdigraph.›
context subsemicategory
begin
interpretation subdg: subdigraph α ‹smc_dg 𝔅› ‹smc_dg ℭ›
by (rule subsmc_subdigraph)
lemmas_with [unfolded slicing_simps]:
subsmc_Obj_vsubset = subdg.subdg_Obj_vsubset
and subsmc_is_arr_vsubset = subdg.subdg_is_arr_vsubset
and subsmc_subdigraph_op_dg_op_dg = subdg.subdg_subdigraph_op_dg_op_dg
and subsmc_objD = subdg.subdg_objD
and subsmc_arrD = subdg.subdg_arrD
and subsmc_dom_simp = subdg.subdg_dom_simp
and subsmc_cod_simp = subdg.subdg_cod_simp
and subsmc_is_arrD = subdg.subdg_is_arrD
and subsmc_dghm_inc_op_dg_is_dghm = subdg.subdg_dghm_inc_op_dg_is_dghm
and subsmc_op_dg_dghm_inc = subdg.subdg_op_dg_dghm_inc
and subsmc_inc_is_ft_dghm_axioms = subdg.inc.is_ft_dghm_axioms
end
lemmas subsmc_subdigraph_op_dg_op_dg[intro] =
subsemicategory.subsmc_subdigraph_op_dg_op_dg
lemmas [smc_sub_fw_cs_intros] =
subsemicategory.subsmc_Obj_vsubset
subsemicategory.subsmc_is_arr_vsubset
subsemicategory.subsmc_objD
subsemicategory.subsmc_arrD
subsemicategory.subsmc_is_arrD
lemmas [smc_sub_bw_cs_simps] =
subsemicategory.subsmc_dom_simp
subsemicategory.subsmc_cod_simp
text‹The opposite subsemicategory.›
lemma (in subsemicategory) subsmc_subsemicategory_op_smc:
"op_smc 𝔅 ⊆⇩S⇩M⇩C⇘α⇙ op_smc ℭ"
proof(rule subsemicategoryI)
fix g b c f a assume prems: "g : b ↦⇘op_smc 𝔅⇙ c" "f : a ↦⇘op_smc 𝔅⇙ b"
then have "g : c ↦⇘𝔅⇙ b" and "f : b ↦⇘𝔅⇙ a"
by (simp_all add: smc_op_simps)
with subsemicategory_axioms have g: "g : c ↦⇘ℭ⇙ b" and f: "f : b ↦⇘ℭ⇙ a"
by (cs_concl cs_intro: smc_sub_fw_cs_intros)+
from dg.op_smc_Comp[OF this(2,1)] have "g ∘⇩A⇘op_smc ℭ⇙ f = f ∘⇩A⇘ℭ⇙ g".
with prems show "g ∘⇩A⇘op_smc 𝔅⇙ f = g ∘⇩A⇘op_smc ℭ⇙ f"
by (simp add: smc_op_simps subsmc_Comp)
qed
(
auto
simp:
smc_op_simps slicing_commute[symmetric] subsmc_subdigraph_op_dg_op_dg
intro: smc_op_intros
)
lemmas subsmc_subsemicategory_op_smc[intro, smc_op_intros] =
subsemicategory.subsmc_subsemicategory_op_smc
text‹Further rules.›
lemma (in subsemicategory) subsmc_Comp_simp:
assumes "g : b ↦⇘𝔅⇙ c" and "f : a ↦⇘𝔅⇙ b"
shows "g ∘⇩A⇘𝔅⇙ f = g ∘⇩A⇘ℭ⇙ f"
using assms subsmc_Comp by auto
lemmas [smc_sub_bw_cs_simps] = subsemicategory.subsmc_Comp_simp
lemma (in subsemicategory) subsmc_is_idem_arrD:
assumes "f : ↦⇩i⇩d⇩e⇘𝔅⇙ b"
shows "f : ↦⇩i⇩d⇩e⇘ℭ⇙ b"
using assms subsemicategory_axioms
by (intro is_idem_arrI; elim is_idem_arrE)
(cs_concl cs_simp: smc_sub_bw_cs_simps[symmetric] cs_intro: smc_sub_fw_cs_intros)
lemmas [smc_sub_fw_cs_intros] = subsemicategory.subsmc_is_idem_arrD
subsubsection‹Subsemicategory relation is a partial order›
lemma subsmc_refl:
assumes "semicategory α 𝔄"
shows "𝔄 ⊆⇩S⇩M⇩C⇘α⇙ 𝔄"
proof-
interpret semicategory α 𝔄 by (rule assms)
show ?thesis
by (auto intro: smc_cs_intros slicing_intros subdg_refl subsemicategoryI)
qed
lemma subsmc_trans[trans]:
assumes "𝔄 ⊆⇩S⇩M⇩C⇘α⇙ 𝔅" and "𝔅 ⊆⇩S⇩M⇩C⇘α⇙ ℭ"
shows "𝔄 ⊆⇩S⇩M⇩C⇘α⇙ ℭ"
proof-
interpret 𝔄𝔅: subsemicategory α 𝔄 𝔅 by (rule assms(1))
interpret 𝔅ℭ: subsemicategory α 𝔅 ℭ by (rule assms(2))
show ?thesis
proof(rule subsemicategoryI)
from 𝔄𝔅.subsmc_subdigraph 𝔅ℭ.subsmc_subdigraph
show "smc_dg 𝔄 ⊆⇩D⇩G⇘α⇙ smc_dg ℭ" by (meson subdg_trans)
show "g ∘⇩A⇘𝔄⇙ f = g ∘⇩A⇘ℭ⇙ f"
if "g : b ↦⇘𝔄⇙ c" and "f : a ↦⇘𝔄⇙ b" for g b c f a
by
(
metis
that
𝔄𝔅.subsmc_is_arr_vsubset
𝔄𝔅.subsmc_Comp_simp
𝔅ℭ.subsmc_Comp_simp
)
qed (auto intro: smc_cs_intros)
qed
lemma subsmc_antisym:
assumes "𝔄 ⊆⇩S⇩M⇩C⇘α⇙ 𝔅" and "𝔅 ⊆⇩S⇩M⇩C⇘α⇙ 𝔄"
shows "𝔄 = 𝔅"
proof-
interpret 𝔄𝔅: subsemicategory α 𝔄 𝔅 by (rule assms(1))
interpret 𝔅𝔄: subsemicategory α 𝔅 𝔄 by (rule assms(2))
show ?thesis
proof(rule smc_eqI)
from subdg_antisym[OF 𝔄𝔅.subsmc_subdigraph 𝔅𝔄.subsmc_subdigraph] have
"smc_dg 𝔄⦇Obj⦈ = smc_dg 𝔅⦇Obj⦈" "smc_dg 𝔄⦇Arr⦈ = smc_dg 𝔅⦇Arr⦈"
by simp_all
then show "𝔄⦇Obj⦈ = 𝔅⦇Obj⦈" and Arr: "𝔄⦇Arr⦈ = 𝔅⦇Arr⦈"
unfolding slicing_simps by simp_all
show "𝔄⦇Dom⦈ = 𝔅⦇Dom⦈"
by (rule vsv_eqI) (auto simp: smc_cs_simps 𝔄𝔅.subsmc_dom_simp Arr)
show "𝔄⦇Cod⦈ = 𝔅⦇Cod⦈"
by (rule vsv_eqI) (auto simp: smc_cs_simps 𝔅𝔄.subsmc_cod_simp Arr)
show "𝔄⦇Comp⦈ = 𝔅⦇Comp⦈"
proof(rule vsv_eqI)
show "𝒟⇩∘ (𝔄⦇Comp⦈) = 𝒟⇩∘ (𝔅⦇Comp⦈)"
proof(intro vsubset_antisym vsubsetI)
fix gf assume "gf ∈⇩∘ 𝒟⇩∘ (𝔄⦇Comp⦈)"
then obtain g f b c a
where gf_def: "gf = [g, f]⇩∘"
and g: "g : b ↦⇘𝔄⇙ c"
and f: "f : a ↦⇘𝔄⇙ b"
by (auto simp: 𝔄𝔅.sdg.smc_Comp_vdomain)
from g f show "gf ∈⇩∘ 𝒟⇩∘ (𝔅⦇Comp⦈)"
unfolding gf_def by (meson 𝔄𝔅.dg.smc_Comp_vdomainI 𝔄𝔅.subsmc_is_arrD)
next
fix gf assume "gf ∈⇩∘ 𝒟⇩∘ (𝔅⦇Comp⦈)"
then obtain g f b c a
where gf_def: "gf = [g, f]⇩∘"
and g: "g : b ↦⇘𝔅⇙ c"
and f: "f : a ↦⇘𝔅⇙ b"
by (auto simp: 𝔄𝔅.dg.smc_Comp_vdomain)
from g f show "gf ∈⇩∘ 𝒟⇩∘ (𝔄⦇Comp⦈)"
unfolding gf_def by (meson 𝔄𝔅.sdg.smc_Comp_vdomainI 𝔅𝔄.subsmc_is_arrD)
qed
show "a ∈⇩∘ 𝒟⇩∘ (𝔄⦇Comp⦈) ⟹ 𝔄⦇Comp⦈⦇a⦈ = 𝔅⦇Comp⦈⦇a⦈" for a
by (metis 𝔄𝔅.sdg.smc_Comp_vdomain 𝔄𝔅.subsmc_Comp_simp)
qed auto
qed (auto intro: smc_cs_intros)
qed
subsection‹Inclusion semifunctor›
subsubsection‹Definition and elementary properties›
text‹See Chapter I-3 in \cite{mac_lane_categories_2010}.›
abbreviation (input) smcf_inc :: "V ⇒ V ⇒ V"
where "smcf_inc ≡ dghm_inc"
text‹Slicing.›
lemma dghm_smcf_inc[slicing_commute]:
"dghm_inc (smc_dg 𝔅) (smc_dg ℭ) = smcf_dghm (smcf_inc 𝔅 ℭ)"
unfolding
smcf_dghm_def dghm_inc_def smc_dg_def dg_field_simps dghm_field_simps
by (simp_all add: nat_omega_simps)
text‹Elementary properties.›
lemmas [smc_cs_simps] =
dghm_inc_ObjMap_app
dghm_inc_ArrMap_app
subsubsection‹Canonical inclusion semifunctor associated with a subsemicategory›
sublocale subsemicategory ⊆ inc: is_ft_semifunctor α 𝔅 ℭ ‹smcf_inc 𝔅 ℭ›
proof(rule is_ft_semifunctorI)
show "smcf_inc 𝔅 ℭ : 𝔅 ↦↦⇩S⇩M⇩C⇘α⇙ ℭ"
proof(rule is_semifunctorI)
show "vfsequence (dghm_inc 𝔅 ℭ)" unfolding dghm_inc_def by auto
show "vcard (dghm_inc 𝔅 ℭ) = 4⇩ℕ"
unfolding dghm_inc_def by (simp add: nat_omega_simps)
fix g b c f a assume prems: "g : b ↦⇘𝔅⇙ c" "f : a ↦⇘𝔅⇙ b"
then have "g ∘⇩A⇘𝔅⇙ f : a ↦⇘𝔅⇙ c" by (simp add: smc_cs_intros)
with subsemicategory_axioms prems have [simp]:
"vid_on (𝔅⦇Arr⦈)⦇g ∘⇩A⇘𝔅⇙ f⦈ = g ∘⇩A⇘ℭ⇙ f"
by (auto simp: smc_sub_bw_cs_simps)
from prems show "dghm_inc 𝔅 ℭ⦇ArrMap⦈⦇g ∘⇩A⇘𝔅⇙ f⦈ =
dghm_inc 𝔅 ℭ⦇ArrMap⦈⦇g⦈ ∘⇩A⇘ℭ⇙ dghm_inc 𝔅 ℭ⦇ArrMap⦈⦇f⦈"
by (cs_concl cs_simp: smc_cs_simps cs_intro: smc_cs_intros smc_sub_fw_cs_intros)
qed
(
insert subsmc_inc_is_ft_dghm_axioms,
auto simp: slicing_commute[symmetric] dghm_inc_components smc_cs_intros
)
qed (auto simp: slicing_commute[symmetric] subsmc_inc_is_ft_dghm_axioms)
lemmas (in subsemicategory) subsmc_smcf_inc_is_ft_semifunctor =
inc.is_ft_semifunctor_axioms
subsubsection‹Inclusion semifunctor for the opposite semicategories›
lemma (in subsemicategory)
subsemicategory_smcf_inc_op_smc_is_semifunctor[smc_sub_cs_intros]:
"smcf_inc (op_smc 𝔅) (op_smc ℭ) : op_smc 𝔅 ↦↦⇩S⇩M⇩C⇩.⇩f⇩a⇩i⇩t⇩h⇩f⇩u⇩l⇘α⇙ op_smc ℭ"
by
(
intro
subsemicategory.subsmc_smcf_inc_is_ft_semifunctor
subsmc_subsemicategory_op_smc
)
lemmas [smc_sub_cs_intros] =
subsemicategory.subsemicategory_smcf_inc_op_smc_is_semifunctor
lemma (in subsemicategory) subdg_op_smc_smcf_inc[smc_op_simps]:
"op_smcf (smcf_inc 𝔅 ℭ) = smcf_inc (op_smc 𝔅) (op_smc ℭ)"
by
(
rule smcf_eqI[of α ‹op_smc 𝔅› ‹op_smc ℭ›],
unfold smc_op_simps dghm_inc_components
)
(
auto simp:
is_ft_semifunctorD
subsemicategory_smcf_inc_op_smc_is_semifunctor
inc.is_semifunctor_op
)
lemmas [smc_op_simps] = subsemicategory.subdg_op_smc_smcf_inc
subsection‹Full subsemicategory›
text‹See Chapter I-3 in \cite{mac_lane_categories_2010}.›
locale fl_subsemicategory = subsemicategory +
assumes fl_subsemicategory_fl_subdigraph: "smc_dg 𝔅 ⊆⇩D⇩G⇩.⇩f⇩u⇩l⇩l⇘α⇙ smc_dg ℭ"
abbreviation is_fl_subsemicategory ("(_/ ⊆⇩S⇩M⇩C⇩.⇩f⇩u⇩l⇩lı _)" [51, 51] 50)
where "𝔅 ⊆⇩S⇩M⇩C⇩.⇩f⇩u⇩l⇩l⇘α⇙ ℭ ≡ fl_subsemicategory α 𝔅 ℭ"
text‹Rules.›
lemma (in fl_subsemicategory) fl_subsemicategory_axioms'[smc_cs_intros]:
assumes "α' = α" and "𝔅' = 𝔅"
shows "𝔅' ⊆⇩S⇩M⇩C⇩.⇩f⇩u⇩l⇩l⇘α'⇙ ℭ"
unfolding assms by (rule fl_subsemicategory_axioms)
lemma (in fl_subsemicategory) fl_subsemicategory_axioms''[smc_cs_intros]:
assumes "α' = α" and "ℭ' = ℭ"
shows "𝔅 ⊆⇩S⇩M⇩C⇩.⇩f⇩u⇩l⇩l⇘α'⇙ ℭ'"
unfolding assms by (rule fl_subsemicategory_axioms)
mk_ide rf fl_subsemicategory_def[unfolded fl_subsemicategory_axioms_def]
|intro fl_subsemicategoryI|
|dest fl_subsemicategoryD[dest]|
|elim fl_subsemicategoryE[elim!]|
lemmas [smc_sub_cs_intros] = fl_subsemicategoryD(1)
text‹Full subsemicategory.›
sublocale fl_subsemicategory ⊆ inc: is_fl_semifunctor α 𝔅 ℭ ‹smcf_inc 𝔅 ℭ›
using fl_subsemicategory_fl_subdigraph inc.is_semifunctor_axioms
by (intro is_fl_semifunctorI) (auto simp: slicing_commute[symmetric])
subsection‹Wide subsemicategory›
subsubsection‹Definition and elementary properties›
text‹
See \cite{noauthor_nlab_nodate}\footnote{
\url{https://ncatlab.org/nlab/show/wide+subcategory}
}).
›
locale wide_subsemicategory = subsemicategory +
assumes wide_subsmc_wide_subdigraph: "smc_dg 𝔅 ⊆⇩D⇩G⇩.⇩w⇩i⇩d⇩e⇘α⇙ smc_dg ℭ"
abbreviation is_wide_subsemicategory ("(_/ ⊆⇩S⇩M⇩C⇩.⇩w⇩i⇩d⇩eı _)" [51, 51] 50)
where "𝔅 ⊆⇩S⇩M⇩C⇩.⇩w⇩i⇩d⇩e⇘α⇙ ℭ ≡ wide_subsemicategory α 𝔅 ℭ"
text‹Rules.›
lemma (in wide_subsemicategory) wide_subsemicategory_axioms'[smc_cs_intros]:
assumes "α' = α" and "𝔅' = 𝔅"
shows "𝔅' ⊆⇩S⇩M⇩C⇩.⇩w⇩i⇩d⇩e⇘α'⇙ ℭ"
unfolding assms by (rule wide_subsemicategory_axioms)
lemma (in wide_subsemicategory) wide_subsemicategory_axioms''[smc_cs_intros]:
assumes "α' = α" and "ℭ' = ℭ"
shows "𝔅 ⊆⇩S⇩M⇩C⇩.⇩w⇩i⇩d⇩e⇘α'⇙ ℭ'"
unfolding assms by (rule wide_subsemicategory_axioms)
mk_ide rf wide_subsemicategory_def[unfolded wide_subsemicategory_axioms_def]
|intro wide_subsemicategoryI|
|dest wide_subsemicategoryD[dest]|
|elim wide_subsemicategoryE[elim!]|
lemmas [smc_sub_cs_intros] = wide_subsemicategoryD(1)
text‹Wide subsemicategory is wide subdigraph.›
context wide_subsemicategory
begin
interpretation wide_subdg: wide_subdigraph α ‹smc_dg 𝔅› ‹smc_dg ℭ›
by (rule wide_subsmc_wide_subdigraph)
lemmas_with [unfolded slicing_simps]:
wide_subsmc_Obj[dg_sub_bw_cs_intros] = wide_subdg.wide_subdg_Obj
and wide_subsmc_obj_eq[dg_sub_bw_cs_simps] = wide_subdg.wide_subdg_obj_eq
end
lemmas [dg_sub_bw_cs_intros] = wide_subsemicategory.wide_subsmc_Obj
lemmas [dg_sub_bw_cs_simps] = wide_subsemicategory.wide_subsmc_obj_eq
subsubsection‹The wide subsemicategory relation is a partial order›
lemma wide_subsmc_refl:
assumes "semicategory α 𝔄"
shows "𝔄 ⊆⇩S⇩M⇩C⇩.⇩w⇩i⇩d⇩e⇘α⇙ 𝔄"
proof-
interpret semicategory α 𝔄 by (rule assms)
show ?thesis
by
(
auto intro:
assms
slicing_intros
wide_subdg_refl
wide_subsemicategoryI
subsmc_refl
)
qed
lemma wide_subsmc_trans[trans]:
assumes "𝔄 ⊆⇩S⇩M⇩C⇩.⇩w⇩i⇩d⇩e⇘α⇙ 𝔅" and "𝔅 ⊆⇩S⇩M⇩C⇩.⇩w⇩i⇩d⇩e⇘α⇙ ℭ"
shows "𝔄 ⊆⇩S⇩M⇩C⇩.⇩w⇩i⇩d⇩e⇘α⇙ ℭ"
proof-
interpret 𝔄𝔅: wide_subsemicategory α 𝔄 𝔅 by (rule assms(1))
interpret 𝔅ℭ: wide_subsemicategory α 𝔅 ℭ by (rule assms(2))
show ?thesis
by
(
intro
wide_subsemicategoryI
subsmc_trans[
OF 𝔄𝔅.subsemicategory_axioms 𝔅ℭ.subsemicategory_axioms
],
rule wide_subdg_trans,
rule 𝔄𝔅.wide_subsmc_wide_subdigraph,
rule 𝔅ℭ.wide_subsmc_wide_subdigraph
)
qed
lemma wide_subsmc_antisym:
assumes "𝔄 ⊆⇩S⇩M⇩C⇩.⇩w⇩i⇩d⇩e⇘α⇙ 𝔅" and "𝔅 ⊆⇩S⇩M⇩C⇩.⇩w⇩i⇩d⇩e⇘α⇙ 𝔄"
shows "𝔄 = 𝔅"
proof-
interpret 𝔄𝔅: wide_subsemicategory α 𝔄 𝔅 by (rule assms(1))
interpret 𝔅𝔄: wide_subsemicategory α 𝔅 𝔄 by (rule assms(2))
show ?thesis
by
(
rule subsmc_antisym[
OF 𝔄𝔅.subsemicategory_axioms 𝔅𝔄.subsemicategory_axioms
]
)
qed
text‹\newpage›
end
Theory CZH_SMC_Simple
section‹Simple semicategories›
theory CZH_SMC_Simple
imports
CZH_DG_Simple
CZH_SMC_Semifunctor
begin
subsection‹Background›
text‹
The section presents a variety of simple semicategories, such as the empty
semicategory ‹0› and a semicategory with one object and one arrow ‹1›.
All of the entities presented in this section are generalizations of certain
simple categories, whose definitions can be found
in \cite{mac_lane_categories_2010}.
›
subsection‹Empty semicategory ‹0››
subsubsection‹Definition and elementary properties›
text‹See Chapter I-2 in \cite{mac_lane_categories_2010}.›
definition smc_0 :: "V"
where "smc_0 = [0, 0, 0, 0, 0]⇩∘"
text‹Components.›
lemma smc_0_components:
shows "smc_0⦇Obj⦈ = 0"
and "smc_0⦇Arr⦈ = 0"
and "smc_0⦇Dom⦈ = 0"
and "smc_0⦇Cod⦈ = 0"
and "smc_0⦇Comp⦈ = 0"
unfolding smc_0_def dg_field_simps by (simp_all add: nat_omega_simps)
text‹Slicing.›
lemma dg_smc_0: "smc_dg smc_0 = dg_0"
unfolding smc_dg_def smc_0_def dg_0_def dg_field_simps
by (simp add: nat_omega_simps)
lemmas_with (in 𝒵) [folded dg_smc_0, unfolded slicing_simps]:
smc_0_is_arr_iff = dg_0_is_arr_iff
subsubsection‹‹0› is a semicategory›
lemma (in 𝒵) semicategory_smc_0: "semicategory α smc_0"
proof(intro semicategoryI)
show "vfsequence smc_0" unfolding smc_0_def by (simp add: nat_omega_simps)
show "vcard smc_0 = 5⇩ℕ" unfolding smc_0_def by (simp add: nat_omega_simps)
show "digraph α (smc_dg smc_0)"
by (simp add: dg_smc_0 𝒵.digraph_dg_0 𝒵_axioms)
qed (auto simp: smc_0_components smc_0_is_arr_iff)
subsubsection‹A semicategory without objects is empty›
lemma (in semicategory) smc_smc_0_if_Obj_0:
assumes "ℭ⦇Obj⦈ = 0"
shows "ℭ = smc_0"
by (rule smc_eqI[of α])
(
auto simp:
smc_cs_intros
assms
semicategory_smc_0
smc_0_components
smc_Arr_vempty_if_Obj_vempty
smc_Cod_vempty_if_Arr_vempty
smc_Dom_vempty_if_Arr_vempty
smc_Comp_vempty_if_Arr_vempty
)
subsection‹Empty semifunctor›
text‹
An empty semifunctor is defined as a semifunctor between an
empty semicategory and an arbitrary semicategory.
›
subsubsection‹Definition and elementary properties›
definition smcf_0 :: "V ⇒ V"
where "smcf_0 𝔄 = [0, 0, smc_0, 𝔄]⇩∘"
text‹Components.›
lemma smcf_0_components:
shows "smcf_0 𝔄⦇ObjMap⦈ = 0"
and "smcf_0 𝔄⦇ArrMap⦈ = 0"
and "smcf_0 𝔄⦇HomDom⦈ = smc_0"
and "smcf_0 𝔄⦇HomCod⦈ = 𝔄"
unfolding smcf_0_def dghm_field_simps by (simp_all add: nat_omega_simps)
text‹Slicing.›
lemma smcf_dghm_smcf_0: "smcf_dghm (smcf_0 𝔄) = dghm_0 (smc_dg 𝔄)"
unfolding
smcf_dghm_def smcf_0_def dg_0_def smc_0_def dghm_0_def smc_dg_def
dg_field_simps dghm_field_simps
by (simp add: nat_omega_simps)
subsubsection‹Empty semifunctor is a faithful semifunctor›
lemma (in 𝒵) smcf_0_is_semifunctor:
assumes "semicategory α 𝔄"
shows "smcf_0 𝔄 : smc_0 ↦↦⇩S⇩M⇩C⇩.⇩f⇩a⇩i⇩t⇩h⇩f⇩u⇩l⇘α⇙ 𝔄"
proof(rule is_ft_semifunctorI)
show "smcf_0 𝔄 : smc_0 ↦↦⇩S⇩M⇩C⇘α⇙ 𝔄"
proof(rule is_semifunctorI, unfold dg_smc_0 smcf_dghm_smcf_0)
show "vfsequence (smcf_0 𝔄)" unfolding smcf_0_def by simp
show "vcard (smcf_0 𝔄) = 4⇩ℕ"
unfolding smcf_0_def by (simp add: nat_omega_simps)
show "dghm_0 (smc_dg 𝔄) : dg_0 ↦↦⇩D⇩G⇘α⇙ smc_dg 𝔄"
by
(
simp add:
assms
dghm_0_is_dghm
is_ft_dghm.axioms(1)
semicategory.smc_digraph
)
qed (auto simp: assms semicategory_smc_0 smcf_0_components smc_0_is_arr_iff)
show "smcf_dghm (smcf_0 𝔄) : smc_dg smc_0 ↦↦⇩D⇩G⇩.⇩f⇩a⇩i⇩t⇩h⇩f⇩u⇩l⇘α⇙ smc_dg 𝔄"
by
(
auto simp:
assms
𝒵.dghm_0_is_dghm
𝒵_axioms
dg_smc_0
semicategory.smc_digraph
smcf_dghm_smcf_0
)
qed
subsection‹‹10›: semicategory with one object and no arrows›
subsubsection‹Definition and elementary properties›
definition smc_10 :: "V ⇒ V"
where "smc_10 𝔞 = [set {𝔞}, 0, 0, 0, 0]⇩∘"
text‹Components.›
lemma smc_10_components:
shows "smc_10 𝔞⦇Obj⦈ = set {𝔞}"
and "smc_10 𝔞⦇Arr⦈ = 0"
and "smc_10 𝔞⦇Dom⦈ = 0"
and "smc_10 𝔞⦇Cod⦈ = 0"
and "smc_10 𝔞⦇Comp⦈ = 0"
unfolding smc_10_def dg_field_simps by (auto simp: nat_omega_simps)
text‹Slicing.›
lemma smc_dg_smc_10: "smc_dg (smc_10 𝔞) = (dg_10 𝔞)"
unfolding smc_dg_def smc_10_def dg_10_def dg_field_simps
by (simp add: nat_omega_simps)
lemmas_with (in 𝒵) [folded smc_dg_smc_10, unfolded slicing_simps]:
smc_10_is_arr_iff = dg_10_is_arr_iff
subsubsection‹‹10› is a semicategory›
lemma (in 𝒵) semicategory_smc_10:
assumes "𝔞 ∈⇩∘ Vset α"
shows "semicategory α (smc_10 𝔞)"
proof(intro semicategoryI)
show "vfsequence (smc_10 𝔞)"
unfolding smc_10_def by (simp add: nat_omega_simps)
show "vcard (smc_10 𝔞) = 5⇩ℕ"
unfolding smc_10_def by (simp add: nat_omega_simps)
show "digraph α (smc_dg (smc_10 𝔞))"
unfolding smc_dg_smc_10 by (rule digraph_dg_10[OF assms])
qed (auto simp: smc_10_components smc_10_is_arr_iff vsubset_vsingleton_leftI)
subsubsection‹Arrow with a domain and a codomain›
lemma smc_10_is_arr_iff: "𝔉 : 𝔄 ↦⇘smc_10 𝔞⇙ 𝔅 ⟷ False"
unfolding is_arr_def smc_10_components by simp
subsection‹‹1›: semicategory with one object and one arrow›
subsubsection‹Definition and elementary properties›
definition smc_1 :: "V ⇒ V ⇒ V"
where "smc_1 𝔞 𝔣 =
[set {𝔞}, set {𝔣}, set {⟨𝔣, 𝔞⟩}, set {⟨𝔣, 𝔞⟩}, set {⟨[𝔣, 𝔣]⇩∘, 𝔣⟩}]⇩∘"
text‹Components.›
lemma smc_1_components:
shows "smc_1 𝔞 𝔣⦇Obj⦈ = set {𝔞}"
and "smc_1 𝔞 𝔣⦇Arr⦈ = set {𝔣}"
and "smc_1 𝔞 𝔣⦇Dom⦈ = set {⟨𝔣, 𝔞⟩}"
and "smc_1 𝔞 𝔣⦇Cod⦈ = set {⟨𝔣, 𝔞⟩}"
and "smc_1 𝔞 𝔣⦇Comp⦈ = set {⟨[𝔣, 𝔣]⇩∘, 𝔣⟩}"
unfolding smc_1_def dg_field_simps by (simp_all add: nat_omega_simps)
text‹Slicing.›
lemma dg_smc_1: "smc_dg (smc_1 𝔞 𝔣) = dg_1 𝔞 𝔣"
unfolding smc_dg_def smc_1_def dg_1_def dg_field_simps
by (simp add: nat_omega_simps)
lemmas_with [folded dg_smc_1, unfolded slicing_simps]:
smc_1_is_arrI = dg_1_is_arrI
and smc_1_is_arrD = dg_1_is_arrD
and smc_1_is_arrE = dg_1_is_arrE
and smc_1_is_arr_iff = dg_1_is_arr_iff
subsubsection‹Composition›
lemma smc_1_Comp_app[simp]: "𝔣 ∘⇩A⇘smc_1 𝔞 𝔣⇙ 𝔣 = 𝔣"
unfolding smc_1_components by simp
subsubsection‹‹1› is a semicategory›
lemma (in 𝒵) semicategory_smc_1:
assumes "𝔞 ∈⇩∘ Vset α" and "𝔣 ∈⇩∘ Vset α"
shows "semicategory α (smc_1 𝔞 𝔣)"
proof(intro semicategoryI, unfold dg_smc_1)
show "vfsequence (smc_1 𝔞 𝔣)"
unfolding smc_1_def by (simp add: nat_omega_simps)
show "vcard (smc_1 𝔞 𝔣) = 5⇩ℕ"
unfolding smc_1_def by (simp add: nat_omega_simps)
qed
(
auto simp:
assms
digraph_dg_1
smc_1_is_arr_iff
smc_1_components
vsubset_vsingleton_leftI
)
text‹\newpage›
end
Theory CZH_SMC_GRPH
section‹‹GRPH› as a semicategory›
theory CZH_SMC_GRPH
imports
CZH_DG_Simple
CZH_DG_GRPH
CZH_SMC_Small_Semicategory
begin
subsection‹Background›
text‹
The methodology for the exposition
of ‹GRPH› as a semicategory is analogous to the
one used in the previous chapter
for the exposition of ‹GRPH› as a digraph.
›
named_theorems smc_GRPH_cs_simps
named_theorems smc_GRPH_cs_intros
subsection‹Definition and elementary properties›
definition smc_GRPH :: "V ⇒ V"
where "smc_GRPH α =
[
set {ℭ. digraph α ℭ},
all_dghms α,
(λ𝔉∈⇩∘all_dghms α. 𝔉⦇HomDom⦈),
(λ𝔉∈⇩∘all_dghms α. 𝔉⦇HomCod⦈),
(λ𝔊𝔉∈⇩∘composable_arrs (dg_GRPH α). 𝔊𝔉⦇0⦈ ∘⇩D⇩G⇩H⇩M 𝔊𝔉⦇1⇩ℕ⦈)
]⇩∘"
text‹Components.›
lemma smc_GRPH_components:
shows "smc_GRPH α⦇Obj⦈ = set {ℭ. digraph α ℭ}"
and "smc_GRPH α⦇Arr⦈ = all_dghms α"
and "smc_GRPH α⦇Dom⦈ = (λ𝔉∈⇩∘all_dghms α. 𝔉⦇HomDom⦈)"
and "smc_GRPH α⦇Cod⦈ = (λ𝔉∈⇩∘all_dghms α. 𝔉⦇HomCod⦈)"
and "smc_GRPH α⦇Comp⦈ =
(λ𝔊𝔉∈⇩∘composable_arrs (dg_GRPH α). 𝔊𝔉⦇0⦈ ∘⇩D⇩G⇩H⇩M 𝔊𝔉⦇1⇩ℕ⦈)"
unfolding smc_GRPH_def dg_field_simps by (simp_all add: nat_omega_simps)
text‹Slicing.›
lemma smc_dg_GRPH: "smc_dg (smc_GRPH α) = dg_GRPH α"
proof(rule vsv_eqI)
show "vsv (smc_dg (smc_GRPH α))" unfolding smc_dg_def by auto
show "vsv (dg_GRPH α)" unfolding dg_GRPH_def by auto
have dom_lhs: "𝒟⇩∘ (smc_dg (smc_GRPH α)) = 4⇩ℕ"
unfolding smc_dg_def by (simp add: nat_omega_simps)
have dom_rhs: "𝒟⇩∘ (dg_GRPH α) = 4⇩ℕ"
unfolding dg_GRPH_def by (simp add: nat_omega_simps)
show "𝒟⇩∘ (smc_dg (smc_GRPH α)) = 𝒟⇩∘ (dg_GRPH α)"
unfolding dom_lhs dom_rhs by simp
show "a ∈⇩∘ 𝒟⇩∘ (smc_dg (smc_GRPH α)) ⟹ smc_dg (smc_GRPH α)⦇a⦈ = dg_GRPH α⦇a⦈"
for a
by
(
unfold dom_lhs,
elim_in_numeral,
unfold smc_dg_def dg_field_simps smc_GRPH_def dg_GRPH_def
)
(auto simp: nat_omega_simps)
qed
lemmas_with [folded smc_dg_GRPH, unfolded slicing_simps]:
smc_GRPH_ObjI = dg_GRPH_ObjI
and smc_GRPH_ObjD = dg_GRPH_ObjD
and smc_GRPH_ObjE = dg_GRPH_ObjE
and smc_GRPH_Obj_iff[smc_GRPH_cs_simps] = dg_GRPH_Obj_iff
and smc_GRPH_Dom_app[smc_GRPH_cs_simps] = dg_GRPH_Dom_app
and smc_GRPH_Cod_app[smc_GRPH_cs_simps] = dg_GRPH_Cod_app
and smc_GRPH_is_arrI = dg_GRPH_is_arrI
and smc_GRPH_is_arrD = dg_GRPH_is_arrD
and smc_GRPH_is_arrE = dg_GRPH_is_arrE
and smc_GRPH_is_arr_iff[smc_GRPH_cs_simps] = dg_GRPH_is_arr_iff
subsection‹Composable arrows›
lemma smc_GRPH_composable_arrs_dg_GRPH:
"composable_arrs (dg_GRPH α) = composable_arrs (smc_GRPH α)"
unfolding composable_arrs_def smc_dg_GRPH[symmetric] slicing_simps by auto
lemma smc_GRPH_Comp:
"smc_GRPH α⦇Comp⦈ = (λ𝔊𝔉∈⇩∘composable_arrs (smc_GRPH α). 𝔊𝔉⦇0⦈ ∘⇩D⇩G⇩H⇩M 𝔊𝔉⦇1⇩ℕ⦈)"
unfolding smc_GRPH_components smc_GRPH_composable_arrs_dg_GRPH ..
subsection‹Composition›
lemma smc_GRPH_Comp_app:
assumes "𝔊 : 𝔅 ↦⇘smc_GRPH α⇙ ℭ" and "𝔉 : 𝔄 ↦⇘smc_GRPH α⇙ 𝔅"
shows "𝔊 ∘⇩A⇘smc_GRPH α⇙ 𝔉 = 𝔊 ∘⇩D⇩G⇩H⇩M 𝔉"
proof-
from assms have "[𝔊, 𝔉]⇩∘ ∈⇩∘ composable_arrs (smc_GRPH α)"
by (auto intro: smc_cs_intros)
then show "𝔊 ∘⇩A⇘smc_GRPH α⇙ 𝔉 = 𝔊 ∘⇩D⇩G⇩H⇩M 𝔉"
unfolding smc_GRPH_Comp by (simp add: nat_omega_simps)
qed
lemma smc_GRPH_Comp_vdomain:
"𝒟⇩∘ (smc_GRPH α⦇Comp⦈) = composable_arrs (smc_GRPH α)"
unfolding smc_GRPH_Comp by auto
subsection‹‹GRPH› is a semicategory›
lemma (in 𝒵) tiny_semicategory_smc_GRPH:
assumes "𝒵 β" and "α ∈⇩∘ β"
shows "tiny_semicategory β (smc_GRPH α)"
proof(intro tiny_semicategoryI, unfold smc_GRPH_is_arr_iff)
show "vfsequence (smc_GRPH α)" unfolding smc_GRPH_def by auto
show "vcard (smc_GRPH α) = 5⇩ℕ"
unfolding smc_GRPH_def by (simp add: nat_omega_simps)
show "(gf ∈⇩∘ 𝒟⇩∘ (smc_GRPH α⦇Comp⦈)) ⟷
(∃g f b c a. gf = [g, f]⇩∘ ∧ g : b ↦↦⇩D⇩G⇘α⇙ c ∧ f : a ↦↦⇩D⇩G⇘α⇙ b)"
for gf
unfolding smc_GRPH_Comp_vdomain
proof
show "gf ∈⇩∘ composable_arrs (smc_GRPH α) ⟹
∃g f b c a. gf = [g, f]⇩∘ ∧ g : b ↦↦⇩D⇩G⇘α⇙ c ∧ f : a ↦↦⇩D⇩G⇘α⇙ b"
by (elim composable_arrsE) (auto simp: smc_GRPH_is_arr_iff)
next
assume "∃g f b c a. gf = [g, f]⇩∘ ∧ g : b ↦↦⇩D⇩G⇘α⇙ c ∧ f : a ↦↦⇩D⇩G⇘α⇙ b"
with smc_GRPH_is_arr_iff show "gf ∈⇩∘ composable_arrs (smc_GRPH α)"
unfolding smc_GRPH_Comp_vdomain by (auto intro: smc_cs_intros)
qed
show "⟦ g : b ↦↦⇩D⇩G⇘α⇙ c; f : a ↦↦⇩D⇩G⇘α⇙ b ⟧ ⟹
g ∘⇩A⇘smc_GRPH α⇙ f : a ↦↦⇩D⇩G⇘α⇙ c"
for g b c f a
by (auto simp: smc_GRPH_Comp_app dghm_comp_is_dghm smc_GRPH_cs_simps)
fix h c d g b f a
assume "h : c ↦↦⇩D⇩G⇘α⇙ d" "g : b ↦↦⇩D⇩G⇘α⇙ c" "f : a ↦↦⇩D⇩G⇘α⇙ b"
moreover then have "g ∘⇩D⇩G⇩H⇩M f : a ↦↦⇩D⇩G⇘α⇙ c" "h ∘⇩D⇩G⇩H⇩M g : b ↦↦⇩D⇩G⇘α⇙ d"
by (auto simp: dghm_comp_is_dghm smc_GRPH_cs_simps)
ultimately show
"h ∘⇩A⇘smc_GRPH α⇙ g ∘⇩A⇘smc_GRPH α⇙ f =
h ∘⇩A⇘smc_GRPH α⇙ (g ∘⇩A⇘smc_GRPH α⇙ f)"
by (simp add: smc_GRPH_is_arr_iff smc_GRPH_Comp_app dghm_comp_assoc)
qed (simp_all add: assms smc_dg_GRPH tiny_digraph_dg_GRPH smc_GRPH_components)
subsection‹Initial object›
lemma (in 𝒵) smc_GRPH_obj_initialI: "obj_initial (smc_GRPH α) dg_0"
unfolding obj_initial_def
proof
(
intro obj_terminalI,
unfold smc_op_simps smc_GRPH_is_arr_iff smc_GRPH_Obj_iff
)
show "digraph α dg_0" by (intro digraph_dg_0)
fix 𝔄 assume "digraph α 𝔄"
then interpret digraph α 𝔄 .
show "∃!f. f : dg_0 ↦↦⇩D⇩G⇘α⇙ 𝔄"
proof
show dghm_0: "dghm_0 𝔄 : dg_0 ↦↦⇩D⇩G⇘α⇙ 𝔄"
by (simp add: dghm_0_is_dghm digraph_axioms is_ft_dghm.axioms(1))
fix 𝔉 assume prems: "𝔉 : dg_0 ↦↦⇩D⇩G⇘α⇙ 𝔄"
then interpret 𝔉: is_dghm α dg_0 𝔄 𝔉 .
show "𝔉 = dghm_0 𝔄"
proof(rule dghm_eqI)
from dghm_0 show "dghm_0 𝔄 : dg_0 ↦↦⇩D⇩G⇘α⇙ 𝔄"
unfolding smc_GRPH_is_arr_iff by simp
have [simp]: "𝒟⇩∘ (𝔉⦇ObjMap⦈) = 0" by (simp add: dg_cs_simps dg_0_components)
with 𝔉.ObjMap.vdomain_vrange_is_vempty show "𝔉⦇ObjMap⦈ = dghm_0 𝔄⦇ObjMap⦈"
by
(
auto
intro: 𝔉.ObjMap.vsv_vrange_vempty
simp: dg_0_components dghm_0_components
)
from 𝔉.dghm_ObjMap_vdomain have "𝒟⇩∘ (𝔉⦇ArrMap⦈) = 0"
by
(
auto
simp: 𝔉.dghm_ArrMap_vdomain
intro: 𝔉.HomDom.dg_Arr_vempty_if_Obj_vempty
)
then show "𝔉⦇ArrMap⦈ = dghm_0 𝔄⦇ArrMap⦈"
by
(
metis
𝔉.ArrMap.vsv_axioms
dghm_0_components(2)
vsv.vdomain_vrange_is_vempty
vsv.vsv_vrange_vempty
)
qed (auto simp: dghm_0_components prems)
qed
qed
lemma (in 𝒵) smc_GRPH_obj_initialD:
assumes "obj_initial (smc_GRPH α) 𝔄"
shows "𝔄 = dg_0"
using assms unfolding obj_initial_def
proof
(
elim obj_terminalE,
unfold smc_op_simps smc_GRPH_is_arr_iff smc_GRPH_Obj_iff
)
assume prems: "digraph α 𝔄" "digraph α 𝔅 ⟹ ∃!𝔉. 𝔉 : 𝔄 ↦↦⇩D⇩G⇘α⇙ 𝔅" for 𝔅
from prems(2)[OF digraph_dg_0] obtain 𝔉 where 𝔉: "𝔉 : 𝔄 ↦↦⇩D⇩G⇘α⇙ dg_0"
by meson
interpret 𝔉: is_dghm α 𝔄 dg_0 𝔉 by (rule 𝔉)
have "ℛ⇩∘ (𝔉⦇ObjMap⦈) ⊆⇩∘ 0"
unfolding dg_0_components(1)[symmetric] by (simp add: 𝔉.dghm_ObjMap_vrange)
then have "𝔉⦇ObjMap⦈ = 0" by (auto intro: 𝔉.ObjMap.vsv_vrange_vempty)
with 𝔉.dghm_ObjMap_vdomain have Obj[simp]: "𝔄⦇Obj⦈ = 0" by auto
have "ℛ⇩∘ (𝔉⦇ArrMap⦈) ⊆⇩∘ 0"
unfolding dg_0_components(2)[symmetric]
by (simp add: 𝔉.dghm_ArrMap_vrange)
then have "𝔉⦇ArrMap⦈ = 0" by (auto intro: 𝔉.ArrMap.vsv_vrange_vempty)
with 𝔉.dghm_ArrMap_vdomain have Arr[simp]: "𝔄⦇Arr⦈ = 0" by auto
from Arr 𝔉.HomDom.dg_Dom_vempty_if_Arr_vempty have [simp]: "𝔄⦇Dom⦈ = []⇩∘"
by auto
from Arr 𝔉.HomDom.dg_Cod_vempty_if_Arr_vempty have [simp]: "𝔄⦇Cod⦈ = []⇩∘"
by auto
show "𝔄 = dg_0"
by (rule dg_eqI[of α]) (simp_all add: prems(1) dg_0_components digraph_dg_0)
qed
lemma (in 𝒵) smc_GRPH_obj_initialE:
assumes "obj_initial (smc_GRPH α) 𝔄"
obtains "𝔄 = dg_0"
using assms by (auto dest: smc_GRPH_obj_initialD)
lemma (in 𝒵) smc_GRPH_obj_initial_iff[smc_GRPH_cs_simps]:
"obj_initial (smc_GRPH α) 𝔄 ⟷ 𝔄 = dg_0"
using smc_GRPH_obj_initialI smc_GRPH_obj_initialD by auto
subsection‹Terminal object›
lemma (in 𝒵) smc_GRPH_obj_terminalI[smc_GRPH_cs_intros]:
assumes "a ∈⇩∘ Vset α" and "f ∈⇩∘ Vset α"
shows "obj_terminal (smc_GRPH α) (dg_1 a f)"
proof
(
intro obj_terminalI,
unfold smc_op_simps smc_GRPH_is_arr_iff smc_GRPH_Obj_iff
)
fix 𝔄 assume "digraph α 𝔄"
then interpret digraph α 𝔄 .
show "∃!𝔉'. 𝔉' : 𝔄 ↦↦⇩D⇩G⇘α⇙ dg_1 a f"
proof
show dghm_1: "dghm_const 𝔄 (dg_1 a f) a f : 𝔄 ↦↦⇩D⇩G⇘α⇙ dg_1 a f"
by
(
auto simp:
assms
dg_1_is_arr_iff
dghm_const_is_dghm
digraph_axioms'
digraph_dg_1
)
fix 𝔉' assume prems: "𝔉' : 𝔄 ↦↦⇩D⇩G⇘α⇙ dg_1 a f"
then interpret 𝔉': is_dghm α 𝔄 ‹dg_1 a f› 𝔉' .
show "𝔉' = dghm_const 𝔄 (dg_1 a f) a f"
proof(rule dghm_eqI, unfold dghm_const_components)
show "dghm_const 𝔄 (dg_1 a f) a f : 𝔄 ↦↦⇩D⇩G⇘α⇙ dg_1 a f" by (rule dghm_1)
show "𝔉'⦇ObjMap⦈ = vconst_on (𝔄⦇Obj⦈) a"
proof(cases‹𝔄⦇Obj⦈ = 0›)
case True
then have "𝔉'⦇ObjMap⦈ = 0"
by
(
simp add:
𝔉'.ObjMap.vdomain_vrange_is_vempty
𝔉'.dghm_ObjMap_vsv
vsv.vsv_vrange_vempty
)
with True show ?thesis by simp
next
case False
then have "𝒟⇩∘ (𝔉'⦇ObjMap⦈) ≠ 0" by (auto simp: 𝔉'.dghm_ObjMap_vdomain)
with False have "ℛ⇩∘ (𝔉'⦇ObjMap⦈) ≠ 0" by fastforce
moreover from 𝔉'.dghm_ObjMap_vrange have "ℛ⇩∘ (𝔉'⦇ObjMap⦈) ⊆⇩∘ set {a}"
by (simp add: dg_1_components)
ultimately have "ℛ⇩∘ (𝔉'⦇ObjMap⦈) = set {a}" by auto
with 𝔉'.dghm_ObjMap_vdomain show ?thesis
by (intro vsv.vsv_is_vconst_onI) blast+
qed
show "𝔉'⦇ArrMap⦈ = vconst_on (𝔄⦇Arr⦈) f"
proof(cases‹𝔄⦇Arr⦈ = 0›)
case True
then have "𝔉'⦇ArrMap⦈ = 0"
by
(
simp add:
𝔉'.ArrMap.vdomain_vrange_is_vempty
𝔉'.dghm_ArrMap_vsv
vsv.vsv_vrange_vempty
)
with True show ?thesis by simp
next
case False
then have "𝒟⇩∘ (𝔉'⦇ArrMap⦈) ≠ 0" by (auto simp: 𝔉'.dghm_ArrMap_vdomain)
with False have "ℛ⇩∘ (𝔉'⦇ArrMap⦈) ≠ 0"
by (force simp: 𝔉'.ArrMap.vdomain_vrange_is_vempty)
moreover from 𝔉'.dghm_ArrMap_vrange have "ℛ⇩∘ (𝔉'⦇ArrMap⦈) ⊆⇩∘ set {f}"
by (simp add: dg_1_components)
ultimately have "ℛ⇩∘ (𝔉'⦇ArrMap⦈) = set {f}" by auto
then show ?thesis
by (intro vsv.vsv_is_vconst_onI) (auto simp: 𝔉'.dghm_ArrMap_vdomain)
qed
qed (auto intro: prems)
qed
qed (simp add: assms digraph_dg_1)
lemma (in 𝒵) smc_GRPH_obj_terminalE:
assumes "obj_terminal (smc_GRPH α) 𝔅"
obtains a f where "a ∈⇩∘ Vset α" and "f ∈⇩∘ Vset α" and "𝔅 = dg_1 a f"
using assms
proof
(
elim obj_terminalE;
unfold smc_op_simps smc_GRPH_is_arr_iff smc_GRPH_Obj_iff
)
assume prems: "digraph α 𝔅" "digraph α 𝔄 ⟹ ∃!𝔉. 𝔉 : 𝔄 ↦↦⇩D⇩G⇘α⇙ 𝔅" for 𝔄
then interpret 𝔅: digraph α 𝔅 by simp
obtain a where 𝔅_Obj: "𝔅⦇Obj⦈ = set {a}" and a: "a ∈⇩∘ Vset α"
proof-
have dg_10: "digraph α (dg_10 0)" by (rule digraph_dg_10) auto
from prems(2)[OF dg_10] obtain 𝔉
where 𝔉: "𝔉 : dg_10 0 ↦↦⇩D⇩G⇘α⇙ 𝔅"
and 𝔊𝔉: "𝔊 : dg_10 0 ↦↦⇩D⇩G⇘α⇙ 𝔅 ⟹ 𝔊 = 𝔉" for 𝔊
by fastforce
interpret 𝔉: is_dghm α ‹dg_10 0› 𝔅 𝔉 by (rule 𝔉)
have "𝒟⇩∘ (𝔉⦇ObjMap⦈) = set {0}"
by (simp add: dg_cs_simps dg_10_components)
then obtain a where vrange_𝔉[simp]: "ℛ⇩∘ (𝔉⦇ObjMap⦈) = set {a}"
by
(
auto
simp: dg_cs_simps
intro: 𝔉.ObjMap.vsv_vdomain_vsingleton_vrange_vsingleton
)
with 𝔅.dg_Obj_vsubset_Vset 𝔉.dghm_ObjMap_vrange have [simp]: "a ∈⇩∘ Vset α"
by auto
from 𝔉.dghm_ObjMap_vrange have "set {a} ⊆⇩∘ 𝔅⦇Obj⦈" by simp
moreover have "𝔅⦇Obj⦈ ⊆⇩∘ set {a}"
proof(rule ccontr)
assume "¬𝔅⦇Obj⦈ ⊆⇩∘ set {a}"
then obtain b where ba: "b ≠ a" and b: "b ∈⇩∘ 𝔅⦇Obj⦈" by force
define 𝔊 where "𝔊 = [set {⟨0, b⟩}, 0, dg_10 0, 𝔅]⇩∘"
have 𝔊_components:
"𝔊⦇ObjMap⦈ = set {⟨0, b⟩}"
"𝔊⦇ArrMap⦈ = 0"
"𝔊⦇HomDom⦈ = dg_10 0"
"𝔊⦇HomCod⦈ = 𝔅"
unfolding 𝔊_def dghm_field_simps by (simp_all add: nat_omega_simps)
have 𝔊: "𝔊 : dg_10 0 ↦↦⇩D⇩G⇘α⇙ 𝔅"
by (rule is_dghmI, unfold 𝔊_components dg_10_components)
(
auto simp:
dg_cs_intros
nat_omega_simps
digraph_dg_10
𝔊_def
dg_10_is_arr_iff
b
vsubset_vsingleton_leftI
)
then have 𝔊_def: "𝔊 = 𝔉" by (rule 𝔊𝔉)
have "ℛ⇩∘ (𝔊⦇ObjMap⦈) = set {b}" unfolding 𝔊_components by simp
with vrange_𝔉 ba show False unfolding 𝔊_def by simp
qed
ultimately have "𝔅⦇Obj⦈ = set {a}" by simp
with that show ?thesis by simp
qed
obtain f where 𝔅_Arr: "𝔅⦇Arr⦈ = set {f}" and f: "f ∈⇩∘ Vset α"
proof-
from prems(2)[OF digraph_dg_1, of 0 0] obtain 𝔉
where 𝔉: "𝔉 : dg_1 0 0 ↦↦⇩D⇩G⇘α⇙ 𝔅"
and 𝔊𝔉: "𝔊 : dg_1 0 0 ↦↦⇩D⇩G⇘α⇙ 𝔅 ⟹ 𝔊 = 𝔉" for 𝔊
by fastforce
interpret 𝔉: is_dghm α ‹dg_1 0 0› 𝔅 𝔉 by (rule 𝔉)
have "𝒟⇩∘ (𝔉⦇ObjMap⦈) = set {0}"
by (simp add: dg_cs_simps dg_1_components)
then obtain a' where "ℛ⇩∘ (𝔉⦇ObjMap⦈) = set {a'}"
by
(
auto
simp: dg_cs_simps
intro: 𝔉.ObjMap.vsv_vdomain_vsingleton_vrange_vsingleton
)
with 𝔅_Obj 𝔉.dghm_ObjMap_vrange have "ℛ⇩∘ (𝔉⦇ObjMap⦈) = set {a}" by auto
have "𝒟⇩∘ (𝔉⦇ArrMap⦈) = set {0}" by (simp add: dg_cs_simps dg_1_components)
then obtain f where vrange_𝔉[simp]: "ℛ⇩∘ (𝔉⦇ArrMap⦈) = set {f}"
by
(
auto
simp: dg_cs_simps
intro: 𝔉.ArrMap.vsv_vdomain_vsingleton_vrange_vsingleton
)
with 𝔅.dg_Arr_vsubset_Vset 𝔉.dghm_ArrMap_vrange have [simp]: "f ∈⇩∘ Vset α"
by auto
from 𝔉.dghm_ArrMap_vrange have "set {f} ⊆⇩∘ 𝔅⦇Arr⦈" by simp
moreover have "𝔅⦇Arr⦈ ⊆⇩∘ set {f}"
proof(rule ccontr)
assume "¬𝔅⦇Arr⦈ ⊆⇩∘ set {f}"
then obtain g where gf: "g ≠ f" and g: "g ∈⇩∘ 𝔅⦇Arr⦈" by force
have g: "g : a ↦⇘𝔅⇙ a"
proof(intro is_arrI)
from g 𝔅_Obj show "𝔅⦇Dom⦈⦇g⦈ = a"
by (metis 𝔅.dg_is_arrD(2) is_arr_def vsingleton_iff)
from g 𝔅_Obj show "𝔅⦇Cod⦈⦇g⦈ = a"
by (metis 𝔅.dg_is_arrD(3) is_arr_def vsingleton_iff)
qed (auto simp: g)
define 𝔊 where "𝔊 = [set {⟨0, a⟩}, set {⟨0, g⟩}, dg_1 0 0, 𝔅]⇩∘"
have 𝔊_components:
"𝔊⦇ObjMap⦈ = set {⟨0, a⟩}"
"𝔊⦇ArrMap⦈ = set {⟨0, g⟩}"
"𝔊⦇HomDom⦈ = dg_1 0 0"
"𝔊⦇HomCod⦈ = 𝔅"
unfolding 𝔊_def dghm_field_simps by (simp_all add: nat_omega_simps)
have 𝔊: "𝔊 : dg_1 0 0 ↦↦⇩D⇩G⇘α⇙ 𝔅"
by (rule is_dghmI, unfold 𝔊_components dg_1_components)
(
auto simp:
dg_cs_intros nat_omega_simps 𝔊_def dg_1_is_arr_iff 𝔅_Obj g
)
then have 𝔊_def: "𝔊 = 𝔉" by (rule 𝔊𝔉)
have "ℛ⇩∘ (𝔊⦇ArrMap⦈) = set {g}" unfolding 𝔊_components by simp
with vrange_𝔉 gf show False unfolding 𝔊_def by simp
qed
ultimately have "𝔅⦇Arr⦈ = set {f}" by simp
with that show ?thesis by simp
qed
have "𝔅 = dg_1 a f"
proof(rule dg_eqI[of α], unfold dg_1_components)
show "𝔅⦇Obj⦈ = set {a}" by (simp add: 𝔅_Obj)
moreover show "𝔅⦇Arr⦈ = set {f}" by (simp add: 𝔅_Arr)
ultimately have "𝔅⦇Dom⦈⦇f⦈ = a" "𝔅⦇Cod⦈⦇f⦈ = a"
by (metis 𝔅.dg_is_arrE is_arr_def vsingleton_iff)+
have "𝒟⇩∘ (𝔅⦇Dom⦈) = set {f}" by (simp add: dg_cs_simps 𝔅_Arr)
moreover from 𝔅.Dom.vsv_vrange_vempty 𝔅.dg_Dom_vdomain 𝔅.dg_Dom_vrange
have "ℛ⇩∘ (𝔅⦇Dom⦈) = set {a}" by (fastforce simp: 𝔅_Arr 𝔅_Obj)
ultimately show "𝔅⦇Dom⦈ = set {⟨f, a⟩}"
using 𝔅.Dom.vsv_vdomain_vrange_vsingleton by simp
have "𝒟⇩∘ (𝔅⦇Cod⦈) = set {f}" by (simp add: dg_cs_simps 𝔅_Arr)
moreover from 𝔅.Cod.vsv_vrange_vempty 𝔅.dg_Cod_vdomain 𝔅.dg_Cod_vrange
have "ℛ⇩∘ (𝔅⦇Cod⦈) = set {a}"
by (fastforce simp: 𝔅_Arr 𝔅_Obj)
ultimately show "𝔅⦇Cod⦈ = set {⟨f, a⟩}"
using assms 𝔅.Cod.vsv_vdomain_vrange_vsingleton by simp
qed (auto simp: dg_cs_intros 𝔅_Obj digraph_dg_1 a f)
with a f that show ?thesis by auto
qed
text‹\newpage›
end
Theory CZH_DG_SemiCAT
section‹‹SemiCAT› as a digraph\label{sec:dg_SemiCAT}›
theory CZH_DG_SemiCAT
imports
CZH_SMC_Semifunctor
CZH_DG_Small_Digraph
begin
subsection‹Background›
text‹
‹SemiCAT› is usually defined as a category of semicategories and semifunctors
(e.g., see \cite{noauthor_nlab_nodate}\footnote{
\url{https://ncatlab.org/nlab/show/semicategory}
}).
However, there is little that can prevent one from exposing ‹SemiCAT›
as a digraph and provide additional structure gradually in
subsequent theories. Thus, in this section, ‹α›-‹SemiCAT› is defined as a
digraph of semicategories and semifunctors in ‹V⇩α›.
›
named_theorems dg_SemiCAT_simps
named_theorems dg_SemiCAT_intros
subsection‹Definition and elementary properties›
definition dg_SemiCAT :: "V ⇒ V"
where "dg_SemiCAT α =
[
set {ℭ. semicategory α ℭ},
all_smcfs α,
(λ𝔉∈⇩∘all_smcfs α. 𝔉⦇HomDom⦈),
(λ𝔉∈⇩∘all_smcfs α. 𝔉⦇HomCod⦈)
]⇩∘"
text‹Components.›
lemma dg_SemiCAT_components:
shows "dg_SemiCAT α⦇Obj⦈ = set {ℭ. semicategory α ℭ}"
and "dg_SemiCAT α⦇Arr⦈ = all_smcfs α"
and "dg_SemiCAT α⦇Dom⦈ = (λ𝔉∈⇩∘all_smcfs α. 𝔉⦇HomDom⦈)"
and "dg_SemiCAT α⦇Cod⦈ = (λ𝔉∈⇩∘all_smcfs α. 𝔉⦇HomCod⦈)"
unfolding dg_SemiCAT_def dg_field_simps by (simp_all add: nat_omega_simps)
subsection‹Object›
lemma dg_SemiCAT_ObjI:
assumes "semicategory α 𝔄"
shows "𝔄 ∈⇩∘ dg_SemiCAT α⦇Obj⦈"
using assms unfolding dg_SemiCAT_components by auto
lemma dg_SemiCAT_ObjD:
assumes "𝔄 ∈⇩∘ dg_SemiCAT α⦇Obj⦈"
shows "semicategory α 𝔄"
using assms unfolding dg_SemiCAT_components by auto
lemma dg_SemiCAT_ObjE:
assumes "𝔄 ∈⇩∘ dg_SemiCAT α⦇Obj⦈"
obtains "semicategory α 𝔄"
using assms unfolding dg_SemiCAT_components by auto
lemma dg_SemiCAT_Obj_iff[dg_SemiCAT_simps]:
"𝔄 ∈⇩∘ dg_SemiCAT α⦇Obj⦈ ⟷ semicategory α 𝔄"
unfolding dg_SemiCAT_components by auto
subsection‹Domain and codomain›
lemma [dg_SemiCAT_simps]:
assumes "𝔉 ∈⇩∘ all_smcfs α"
shows dg_SemiCAT_Dom_app: "dg_SemiCAT α⦇Dom⦈⦇𝔉⦈ = 𝔉⦇HomDom⦈"
and dg_SemiCAT_Cod_app: "dg_SemiCAT α⦇Cod⦈⦇𝔉⦈ = 𝔉⦇HomCod⦈"
using assms unfolding dg_SemiCAT_components by auto
subsection‹‹SemiCAT› is a digraph›
lemma (in 𝒵) tiny_digraph_dg_SemiCAT:
assumes "𝒵 β" and "α ∈⇩∘ β"
shows "tiny_digraph β (dg_SemiCAT α)"
proof(intro tiny_digraphI)
show "vfsequence (dg_SemiCAT α)" unfolding dg_SemiCAT_def by simp
show "vcard (dg_SemiCAT α) = 4⇩ℕ"
unfolding dg_SemiCAT_def by (simp add: nat_omega_simps)
show "ℛ⇩∘ (dg_SemiCAT α⦇Dom⦈) ⊆⇩∘ dg_SemiCAT α⦇Obj⦈"
proof(intro vsubsetI)
fix 𝔄 assume "𝔄 ∈⇩∘ ℛ⇩∘ (dg_SemiCAT α⦇Dom⦈)"
then obtain 𝔉
where "𝔉 ∈⇩∘ all_smcfs α" and 𝔄_def: "𝔄 = 𝔉⦇HomDom⦈"
unfolding dg_SemiCAT_components by auto
then obtain 𝔅 𝔉 where "𝔉 : 𝔄 ↦↦⇩S⇩M⇩C⇘α⇙ 𝔅"
unfolding dg_SemiCAT_components by auto
then interpret is_semifunctor α 𝔄 𝔅 𝔉 .
show "𝔄 ∈⇩∘ dg_SemiCAT α⦇Obj⦈"
by (simp add: dg_SemiCAT_components HomDom.semicategory_axioms)
qed
show "ℛ⇩∘ (dg_SemiCAT α⦇Cod⦈) ⊆⇩∘ dg_SemiCAT α⦇Obj⦈"
proof(intro vsubsetI)
fix 𝔅 assume "𝔅 ∈⇩∘ ℛ⇩∘ (dg_SemiCAT α⦇Cod⦈)"
then obtain 𝔉 where "𝔉 ∈⇩∘ 𝒟⇩∘ (dg_SemiCAT α⦇Cod⦈)" and "𝔅 = 𝔉⦇HomCod⦈"
unfolding dg_SemiCAT_components by auto
then obtain 𝔄 𝔉
where 𝔉: "𝔉 : 𝔄 ↦↦⇩S⇩M⇩C⇘α⇙ 𝔅" and 𝔄_def: "𝔅 = 𝔉⦇HomCod⦈"
unfolding dg_SemiCAT_components by auto
have "𝔅 = 𝔉⦇HomCod⦈" unfolding 𝔄_def by simp
interpret is_semifunctor α 𝔄 𝔅 𝔉 by (rule 𝔉)
show "𝔅 ∈⇩∘ dg_SemiCAT α⦇Obj⦈"
by (simp add: HomCod.semicategory_axioms dg_SemiCAT_components)
qed
show "dg_SemiCAT α⦇Obj⦈ ∈⇩∘ Vset β"
unfolding dg_SemiCAT_components by (rule semicategories_in_Vset[OF assms])
show "dg_SemiCAT α⦇Arr⦈ ∈⇩∘ Vset β"
unfolding dg_SemiCAT_components by (rule all_smcfs_in_Vset[OF assms])
qed (simp_all add: assms dg_SemiCAT_components)
subsection‹Arrow with a domain and a codomain›
lemma dg_SemiCAT_is_arrI:
assumes "𝔉 : 𝔄 ↦↦⇩S⇩M⇩C⇘α⇙ 𝔅"
shows "𝔉 : 𝔄 ↦⇘dg_SemiCAT α⇙ 𝔅"
proof(intro is_arrI, unfold dg_SemiCAT_components(2))
interpret is_semifunctor α 𝔄 𝔅 𝔉 by (rule assms)
from assms show "𝔉 ∈⇩∘ all_smcfs α" by auto
with assms show "dg_SemiCAT α⦇Dom⦈⦇𝔉⦈ = 𝔄" "dg_SemiCAT α⦇Cod⦈⦇𝔉⦈ = 𝔅"
by (simp_all add: smc_cs_simps dg_SemiCAT_components)
qed
lemma dg_SemiCAT_is_arrD:
assumes "𝔉 : 𝔄 ↦⇘dg_SemiCAT α⇙ 𝔅"
shows "𝔉 : 𝔄 ↦↦⇩S⇩M⇩C⇘α⇙ 𝔅"
using assms by (elim is_arrE) (auto simp: dg_SemiCAT_components)
lemma dg_SemiCAT_is_arrE:
assumes "𝔉 : 𝔄 ↦⇘dg_SemiCAT α⇙ 𝔅"
obtains "𝔉 : 𝔄 ↦↦⇩S⇩M⇩C⇘α⇙ 𝔅"
using assms by (simp add: dg_SemiCAT_is_arrD)
lemma dg_SemiCAT_is_arr_iff[dg_SemiCAT_simps]:
"𝔉 : 𝔄 ↦⇘dg_SemiCAT α⇙ 𝔅 ⟷ 𝔉 : 𝔄 ↦↦⇩S⇩M⇩C⇘α⇙ 𝔅"
by (auto intro: dg_SemiCAT_is_arrI dest: dg_SemiCAT_is_arrD)
text‹\newpage›
end
Theory CZH_SMC_SemiCAT
section‹‹SemiCAT› as a semicategory›
theory CZH_SMC_SemiCAT
imports
CZH_DG_SemiCAT
CZH_SMC_Simple
CZH_SMC_Small_Semicategory
begin
subsection‹Background›
text‹
The subsection presents the theory of the semicategories of
‹α›-semicategories.
It continues the development that was initiated in section
\ref{sec:dg_SemiCAT}.
›
named_theorems smc_SemiCAT_simps
named_theorems smc_SemiCAT_intros
subsection‹Definition and elementary properties›
definition smc_SemiCAT :: "V ⇒ V"
where "smc_SemiCAT α =
[
set {ℭ. semicategory α ℭ},
all_smcfs α,
(λ𝔉∈⇩∘all_smcfs α. 𝔉⦇HomDom⦈),
(λ𝔉∈⇩∘all_smcfs α. 𝔉⦇HomCod⦈),
(λ𝔊𝔉∈⇩∘composable_arrs (dg_SemiCAT α). 𝔊𝔉⦇0⦈ ∘⇩S⇩M⇩C⇩F 𝔊𝔉⦇1⇩ℕ⦈)
]⇩∘"
text‹Components.›
lemma smc_SemiCAT_components:
shows "smc_SemiCAT α⦇Obj⦈ = set {ℭ. semicategory α ℭ}"
and "smc_SemiCAT α⦇Arr⦈ = all_smcfs α"
and "smc_SemiCAT α⦇Dom⦈ = (λ𝔉∈⇩∘all_smcfs α. 𝔉⦇HomDom⦈)"
and "smc_SemiCAT α⦇Cod⦈ = (λ𝔉∈⇩∘all_smcfs α. 𝔉⦇HomCod⦈)"
and "smc_SemiCAT α⦇Comp⦈ =
(λ𝔊𝔉∈⇩∘composable_arrs (dg_SemiCAT α). 𝔊𝔉⦇0⦈ ∘⇩S⇩M⇩C⇩F 𝔊𝔉⦇1⇩ℕ⦈)"
unfolding smc_SemiCAT_def dg_field_simps
by (simp_all add: nat_omega_simps)
text‹Slicing.›
lemma smc_dg_SemiCAT[smc_SemiCAT_simps]: "smc_dg (smc_SemiCAT α) = dg_SemiCAT α"
proof(rule vsv_eqI)
show "vsv (smc_dg (smc_SemiCAT α))" unfolding smc_dg_def by auto
show "vsv (dg_SemiCAT α)" unfolding dg_SemiCAT_def by auto
have dom_lhs: "𝒟⇩∘ (smc_dg (smc_SemiCAT α)) = 4⇩ℕ"
unfolding smc_dg_def by (simp add: nat_omega_simps)
have dom_rhs: "𝒟⇩∘ (dg_SemiCAT α) = 4⇩ℕ"
unfolding dg_SemiCAT_def by (simp add: nat_omega_simps)
show "𝒟⇩∘ (smc_dg (smc_SemiCAT α)) = 𝒟⇩∘ (dg_SemiCAT α)"
unfolding dom_lhs dom_rhs by simp
show "a ∈⇩∘ 𝒟⇩∘ (smc_dg (smc_SemiCAT α)) ⟹
smc_dg (smc_SemiCAT α)⦇a⦈ = dg_SemiCAT α⦇a⦈"
for a
by
(
unfold dom_lhs,
elim_in_numeral,
unfold smc_dg_def dg_field_simps smc_SemiCAT_def dg_SemiCAT_def
)
(auto simp: nat_omega_simps)
qed
lemmas_with [folded smc_dg_SemiCAT, unfolded slicing_simps]:
smc_SemiCAT_ObjI = dg_SemiCAT_ObjI
and smc_SemiCAT_ObjD = dg_SemiCAT_ObjD
and smc_SemiCAT_ObjE = dg_SemiCAT_ObjE
and smc_SemiCAT_Obj_iff[smc_SemiCAT_simps] = dg_SemiCAT_Obj_iff
and smc_SemiCAT_Dom_app[smc_SemiCAT_simps] = dg_SemiCAT_Dom_app
and smc_SemiCAT_Cod_app[smc_SemiCAT_simps] = dg_SemiCAT_Cod_app
and smc_SemiCAT_is_arrI = dg_SemiCAT_is_arrI
and smc_SemiCAT_is_arrD = dg_SemiCAT_is_arrD
and smc_SemiCAT_is_arrE = dg_SemiCAT_is_arrE
and smc_SemiCAT_is_arr_iff[smc_SemiCAT_simps] = dg_SemiCAT_is_arr_iff
subsection‹Composable arrows›
lemma smc_SemiCAT_composable_arrs_dg_SemiCAT:
"composable_arrs (dg_SemiCAT α) = composable_arrs (smc_SemiCAT α)"
unfolding composable_arrs_def smc_dg_SemiCAT[symmetric] slicing_simps by auto
lemma smc_SemiCAT_Comp:
"smc_SemiCAT α⦇Comp⦈ =
(λ𝔊𝔉∈⇩∘composable_arrs (smc_SemiCAT α). 𝔊𝔉⦇0⦈ ∘⇩D⇩G⇩H⇩M 𝔊𝔉⦇1⇩ℕ⦈)"
unfolding smc_SemiCAT_components smc_SemiCAT_composable_arrs_dg_SemiCAT ..
subsection‹Composition›
lemma smc_SemiCAT_Comp_app[smc_SemiCAT_simps]:
assumes "𝔊 : 𝔅 ↦⇘smc_SemiCAT α⇙ ℭ" and "𝔉 : 𝔄 ↦⇘smc_SemiCAT α⇙ 𝔅"
shows "𝔊 ∘⇩A⇘smc_SemiCAT α⇙ 𝔉 = 𝔊 ∘⇩S⇩M⇩C⇩F 𝔉"
proof-
from assms have "[𝔊, 𝔉]⇩∘ ∈⇩∘ composable_arrs (smc_SemiCAT α)"
by (auto simp: composable_arrsI)
then show "𝔊 ∘⇩A⇘smc_SemiCAT α⇙ 𝔉 = 𝔊 ∘⇩S⇩M⇩C⇩F 𝔉"
unfolding smc_SemiCAT_Comp by (simp add: nat_omega_simps)
qed
lemma smc_SemiCAT_Comp_vdomain[smc_SemiCAT_simps]:
"𝒟⇩∘ (smc_SemiCAT α⦇Comp⦈) = composable_arrs (smc_SemiCAT α)"
unfolding smc_SemiCAT_Comp by auto
lemma smc_SemiCAT_Comp_vrange: "ℛ⇩∘ (smc_SemiCAT α⦇Comp⦈) ⊆⇩∘ all_smcfs α"
proof(rule vsubsetI)
fix ℌ assume "ℌ ∈⇩∘ ℛ⇩∘ (smc_SemiCAT α⦇Comp⦈)"
then obtain 𝔊𝔉
where ℌ_def: "ℌ = smc_SemiCAT α⦇Comp⦈⦇𝔊𝔉⦈"
and "𝔊𝔉 ∈⇩∘ 𝒟⇩∘ (smc_SemiCAT α⦇Comp⦈)"
unfolding smc_SemiCAT_components by (auto intro: composable_arrsI)
then obtain 𝔊 𝔉 𝔄 𝔅 ℭ
where "𝔊𝔉 = [𝔊, 𝔉]⇩∘"
and 𝔊: "𝔊 : 𝔅 ↦⇘smc_SemiCAT α⇙ ℭ"
and 𝔉: "𝔉 : 𝔄 ↦⇘smc_SemiCAT α⇙ 𝔅"
by (auto simp: smc_SemiCAT_Comp_vdomain)
with ℌ_def have ℌ_def': "ℌ = 𝔊 ∘⇩A⇘smc_SemiCAT α⇙ 𝔉" by simp
from 𝔊 𝔉 show "ℌ ∈⇩∘ all_smcfs α"
unfolding ℌ_def' by (auto intro: smc_cs_intros simp: smc_SemiCAT_simps)
qed
subsection‹‹SemiCAT› is a semicategory›
lemma (in 𝒵) tiny_semicategory_smc_SemiCAT:
assumes "𝒵 β" and "α ∈⇩∘ β"
shows "tiny_semicategory β (smc_SemiCAT α)"
proof(intro tiny_semicategoryI, unfold smc_SemiCAT_is_arr_iff)
show "vfsequence (smc_SemiCAT α)" unfolding smc_SemiCAT_def by auto
show "vcard (smc_SemiCAT α) = 5⇩ℕ"
unfolding smc_SemiCAT_def by (simp add: nat_omega_simps)
show "(𝔊𝔉 ∈⇩∘ 𝒟⇩∘ (smc_SemiCAT α⦇Comp⦈)) ⟷
(∃𝔊 𝔉 𝔅 ℭ 𝔄. 𝔊𝔉 = [𝔊, 𝔉]⇩∘ ∧ 𝔊 : 𝔅 ↦↦⇩S⇩M⇩C⇘α⇙ ℭ ∧ 𝔉 : 𝔄 ↦↦⇩S⇩M⇩C⇘α⇙ 𝔅)"
for 𝔊𝔉
unfolding smc_SemiCAT_Comp_vdomain
proof
show "𝔊𝔉 ∈⇩∘ composable_arrs (smc_SemiCAT α) ⟹
∃𝔊 𝔉 𝔅 ℭ 𝔄. 𝔊𝔉 = [𝔊, 𝔉]⇩∘ ∧ 𝔊 : 𝔅 ↦↦⇩S⇩M⇩C⇘α⇙ ℭ ∧ 𝔉 : 𝔄 ↦↦⇩S⇩M⇩C⇘α⇙ 𝔅"
by (elim composable_arrsE) (auto simp: smc_SemiCAT_is_arr_iff)
next
assume "∃𝔊 𝔉 𝔅 ℭ 𝔄. 𝔊𝔉 = [𝔊, 𝔉]⇩∘ ∧ 𝔊 : 𝔅 ↦↦⇩S⇩M⇩C⇘α⇙ ℭ ∧ 𝔉 : 𝔄 ↦↦⇩S⇩M⇩C⇘α⇙ 𝔅"
with smc_SemiCAT_is_arr_iff show "𝔊𝔉 ∈⇩∘ composable_arrs (smc_SemiCAT α)"
unfolding smc_SemiCAT_Comp_vdomain by (auto intro: smc_cs_intros)
qed
show "⟦ 𝔊 : 𝔅 ↦↦⇩S⇩M⇩C⇘α⇙ ℭ; 𝔉 : 𝔄 ↦↦⇩S⇩M⇩C⇘α⇙ 𝔅 ⟧ ⟹
𝔊 ∘⇩A⇘smc_SemiCAT α⇙ 𝔉 : 𝔄 ↦↦⇩S⇩M⇩C⇘α⇙ ℭ"
for 𝔊 𝔅 ℭ 𝔉 𝔄
by (auto simp: smc_SemiCAT_simps intro: smc_cs_intros)
fix ℌ ℭ 𝔇 𝔊 𝔅 𝔉 𝔄
assume "ℌ : ℭ ↦↦⇩S⇩M⇩C⇘α⇙ 𝔇" "𝔊 : 𝔅 ↦↦⇩S⇩M⇩C⇘α⇙ ℭ" "𝔉 : 𝔄 ↦↦⇩S⇩M⇩C⇘α⇙ 𝔅"
moreover then have "𝔊 ∘⇩S⇩M⇩C⇩F 𝔉 : 𝔄 ↦↦⇩S⇩M⇩C⇘α⇙ ℭ" "ℌ ∘⇩S⇩M⇩C⇩F 𝔊 : 𝔅 ↦↦⇩S⇩M⇩C⇘α⇙ 𝔇"
by (auto intro: smc_cs_intros)
ultimately show "ℌ ∘⇩A⇘smc_SemiCAT α⇙ 𝔊 ∘⇩A⇘smc_SemiCAT α⇙ 𝔉 =
ℌ ∘⇩A⇘smc_SemiCAT α⇙ (𝔊 ∘⇩A⇘smc_SemiCAT α⇙ 𝔉)"
by
(
simp add:
smc_SemiCAT_is_arr_iff smc_SemiCAT_Comp_app smcf_comp_assoc
)
qed
(
auto simp:
assms smc_dg_SemiCAT tiny_digraph_dg_SemiCAT smc_SemiCAT_components
)
subsection‹Initial object›
lemma (in 𝒵) smc_SemiCAT_obj_initialI: "obj_initial (smc_SemiCAT α) smc_0"
unfolding obj_initial_def
proof
(
intro obj_terminalI,
unfold smc_op_simps smc_SemiCAT_is_arr_iff smc_SemiCAT_Obj_iff
)
show "semicategory α smc_0" by (intro semicategory_smc_0)
fix 𝔄 assume prems: "semicategory α 𝔄"
interpret semicategory α 𝔄 using prems .
show "∃!𝔉. 𝔉 : smc_0 ↦↦⇩S⇩M⇩C⇘α⇙ 𝔄"
proof
show smcf_0: "smcf_0 𝔄 : smc_0 ↦↦⇩S⇩M⇩C⇘α⇙ 𝔄"
by
(
simp add:
smcf_0_is_semifunctor semicategory_axioms is_ft_semifunctor.axioms(1)
)
fix 𝔉 assume prems: "𝔉 : smc_0 ↦↦⇩S⇩M⇩C⇘α⇙ 𝔄"
then interpret 𝔉: is_semifunctor α smc_0 𝔄 𝔉 .
show "𝔉 = smcf_0 𝔄"
proof(rule smcf_eqI)
show "𝔉 : smc_0 ↦↦⇩S⇩M⇩C⇘α⇙ 𝔄" by (auto simp: smc_cs_intros)
from smcf_0 show "smcf_0 𝔄 : smc_0 ↦↦⇩S⇩M⇩C⇘α⇙ 𝔄"
unfolding smc_SemiCAT_is_arr_iff by simp
have "𝒟⇩∘ (𝔉⦇ObjMap⦈) = 0" by (auto simp: smc_0_components smc_cs_simps)
with 𝔉.ObjMap.vdomain_vrange_is_vempty show "𝔉⦇ObjMap⦈ = smcf_0 𝔄⦇ObjMap⦈"
unfolding smcf_0_components by (auto intro: 𝔉.ObjMap.vsv_vrange_vempty)
have "𝒟⇩∘ (𝔉⦇ArrMap⦈) = 0" by (auto simp: smc_0_components smc_cs_simps)
with 𝔉.ArrMap.vdomain_vrange_is_vempty show "𝔉⦇ArrMap⦈ = smcf_0 𝔄⦇ArrMap⦈"
unfolding smcf_0_components by (auto intro: 𝔉.ArrMap.vsv_vrange_vempty)
qed (simp_all add: smcf_0_components)
qed
qed
lemma (in 𝒵) smc_SemiCAT_obj_initialD:
assumes "obj_initial (smc_SemiCAT α) 𝔄"
shows "𝔄 = smc_0"
using assms unfolding obj_initial_def
proof
(
elim obj_terminalE,
unfold smc_op_simps smc_SemiCAT_is_arr_iff smc_SemiCAT_Obj_iff
)
assume prems:
"semicategory α 𝔄"
"semicategory α 𝔅 ⟹ ∃!𝔉. 𝔉 : 𝔄 ↦↦⇩S⇩M⇩C⇘α⇙ 𝔅"
for 𝔅
from prems(2)[OF semicategory_smc_0] obtain 𝔉 where "𝔉 : 𝔄 ↦↦⇩S⇩M⇩C⇘α⇙ smc_0"
by meson
then interpret 𝔉: is_semifunctor α 𝔄 smc_0 𝔉 .
have "ℛ⇩∘ (𝔉⦇ObjMap⦈) ⊆⇩∘ 0"
unfolding smc_0_components(1)[symmetric]
by (simp add: 𝔉.smcf_ObjMap_vrange)
then have "𝔉⦇ObjMap⦈ = 0" by (auto intro: 𝔉.ObjMap.vsv_vrange_vempty)
with 𝔉.smcf_ObjMap_vdomain have Obj[simp]: "𝔄⦇Obj⦈ = 0" by auto
have "ℛ⇩∘ (𝔉⦇ArrMap⦈) ⊆⇩∘ 0"
unfolding smc_0_components(2)[symmetric]
by (simp add: 𝔉.smcf_ArrMap_vrange)
then have "𝔉⦇ArrMap⦈ = 0" by (auto intro: 𝔉.ArrMap.vsv_vrange_vempty)
with 𝔉.smcf_ArrMap_vdomain have Arr[simp]: "𝔄⦇Arr⦈ = 0" by auto
from 𝔉.HomDom.Dom.vdomain_vrange_is_vempty have [simp]: "𝔄⦇Dom⦈ = 0"
by (auto simp: smc_cs_simps intro: 𝔉.HomDom.Dom.vsv_vrange_vempty)
from 𝔉.HomDom.Cod.vdomain_vrange_is_vempty have [simp]: "𝔄⦇Cod⦈ = 0"
by (auto simp: smc_cs_simps intro: 𝔉.HomDom.Cod.vsv_vrange_vempty)
from Arr have "𝔄⦇Arr⦈ ^⇩× 2⇩ℕ = 0" by (simp add: vcpower_of_vempty)
with 𝔉.HomDom.Comp.pnop_vdomain have "𝒟⇩∘ (𝔄⦇Comp⦈) = 0" by simp
with 𝔉.HomDom.Comp.vdomain_vrange_is_vempty have [simp]: "𝔄⦇Comp⦈ = 0"
by (auto intro: 𝔉.HomDom.Comp.vsv_vrange_vempty)
show "𝔄 = smc_0"
by (rule smc_eqI[of α])
(simp_all add: prems(1) smc_0_components semicategory_smc_0)
qed
lemma (in 𝒵) smc_SemiCAT_obj_initialE:
assumes "obj_initial (smc_SemiCAT α) 𝔄"
obtains "𝔄 = smc_0"
using assms by (auto dest: smc_SemiCAT_obj_initialD)
lemma (in 𝒵) smc_SemiCAT_obj_initial_iff[smc_SemiCAT_simps]:
"obj_initial (smc_SemiCAT α) 𝔄 ⟷ 𝔄 = smc_0"
using smc_SemiCAT_obj_initialI smc_SemiCAT_obj_initialD by auto
subsection‹Terminal object›
lemma (in 𝒵) smc_SemiCAT_obj_terminalI[smc_SemiCAT_intros]:
assumes "a ∈⇩∘ Vset α" and "f ∈⇩∘ Vset α"
shows "obj_terminal (smc_SemiCAT α) (smc_1 a f)"
proof
(
intro obj_terminalI,
unfold smc_op_simps smc_SemiCAT_is_arr_iff smc_SemiCAT_Obj_iff
)
fix 𝔄 assume "semicategory α 𝔄"
then interpret semicategory α 𝔄 .
show "∃!𝔉'. 𝔉' : 𝔄 ↦↦⇩S⇩M⇩C⇘α⇙ smc_1 a f"
proof
show smcf_1: "smcf_const 𝔄 (smc_1 a f) a f : 𝔄 ↦↦⇩S⇩M⇩C⇘α⇙ smc_1 a f"
by
(
auto
intro: smc_cs_intros smc_1_is_arrI smcf_const_is_semifunctor
simp: assms semicategory_smc_1
)
fix 𝔉' assume "𝔉' : 𝔄 ↦↦⇩S⇩M⇩C⇘α⇙ smc_1 a f"
then interpret 𝔉': is_semifunctor α 𝔄 ‹smc_1 a f› 𝔉' .
show "𝔉' = smcf_const 𝔄 (smc_1 a f) a f"
proof(rule smcf_eqI, unfold dghm_const_components)
show "smcf_const 𝔄 (smc_1 a f) a f : 𝔄 ↦↦⇩S⇩M⇩C⇘α⇙ smc_1 a f"
by (rule smcf_1)
show "𝔉'⦇ObjMap⦈ = vconst_on (𝔄⦇Obj⦈) a"
proof(cases‹𝔄⦇Obj⦈ = 0›)
case True
with 𝔉'.ObjMap.vbrelation_vintersection_vdomain have "𝔉'⦇ObjMap⦈ = 0"
by (auto simp: smc_cs_simps)
with True show ?thesis by simp
next
case False
then have "𝒟⇩∘ (𝔉'⦇ObjMap⦈) ≠ 0" by (auto simp: smc_cs_simps)
then have "ℛ⇩∘ (𝔉'⦇ObjMap⦈) ≠ 0"
by (simp add: 𝔉'.ObjMap.vsv_vdomain_vempty_vrange_vempty)
moreover from 𝔉'.smcf_ObjMap_vrange have "ℛ⇩∘ (𝔉'⦇ObjMap⦈) ⊆⇩∘ set {a}"
by (simp add: smc_1_components)
ultimately have "ℛ⇩∘ (𝔉'⦇ObjMap⦈) = set {a}" by auto
then show ?thesis
by (intro vsv.vsv_is_vconst_onI) (auto simp: smc_cs_simps)
qed
show "𝔉'⦇ArrMap⦈ = vconst_on (𝔄⦇Arr⦈) f"
proof(cases‹𝔄⦇Arr⦈ = 0›)
case True
with 𝔉'.ArrMap.vdomain_vrange_is_vempty have "𝔉'⦇ArrMap⦈ = 0"
by (simp add: smc_cs_simps 𝔉'.smcf_ArrMap_vsv vsv.vsv_vrange_vempty)
with True show ?thesis by simp
next
case False
then have "𝒟⇩∘ (𝔉'⦇ArrMap⦈) ≠ 0" by (auto simp: smc_cs_simps)
then have "ℛ⇩∘ (𝔉'⦇ArrMap⦈) ≠ 0"
by (simp add: 𝔉'.ArrMap.vsv_vdomain_vempty_vrange_vempty)
moreover from 𝔉'.smcf_ArrMap_vrange have "ℛ⇩∘ (𝔉'⦇ArrMap⦈) ⊆⇩∘ set {f}"
by (simp add: smc_1_components)
ultimately have "ℛ⇩∘ (𝔉'⦇ArrMap⦈) = set {f}" by auto
then show ?thesis
by (intro vsv.vsv_is_vconst_onI) (auto simp: smc_cs_simps)
qed
qed (auto intro: smc_cs_intros)
qed
qed (simp add: assms semicategory_smc_1)
lemma (in 𝒵) smc_SemiCAT_obj_terminalE:
assumes "obj_terminal (smc_SemiCAT α) 𝔅"
obtains a f where "a ∈⇩∘ Vset α" and "f ∈⇩∘ Vset α" and "𝔅 = smc_1 a f"
using assms
proof
(
elim obj_terminalE,
unfold smc_op_simps smc_SemiCAT_is_arr_iff smc_SemiCAT_Obj_iff
)
assume prems:
"semicategory α 𝔅"
"semicategory α 𝔄 ⟹ ∃!𝔉. 𝔉 : 𝔄 ↦↦⇩S⇩M⇩C⇘α⇙ 𝔅"
for 𝔄
interpret 𝔅: semicategory α 𝔅 by (rule prems(1))
obtain a where 𝔅_Obj: "𝔅⦇Obj⦈ = set {a}" and a: "a ∈⇩∘ Vset α"
proof-
have semicategory_smc_10: "semicategory α (smc_10 0)"
by (intro semicategory_smc_10) auto
from prems(2)[OF semicategory_smc_10] obtain 𝔉
where 𝔉: "𝔉 : smc_10 0 ↦↦⇩S⇩M⇩C⇘α⇙ 𝔅"
and 𝔊𝔉: "𝔊 : smc_10 0 ↦↦⇩S⇩M⇩C⇘α⇙ 𝔅 ⟹ 𝔊 = 𝔉" for 𝔊
by fastforce
interpret 𝔉: is_semifunctor α ‹smc_10 0› 𝔅 𝔉 by (rule 𝔉)
have "𝒟⇩∘ (𝔉⦇ObjMap⦈) = set {0}"
by (auto simp add: smc_10_components smc_cs_simps)
then obtain a where vrange_𝔉[simp]: "ℛ⇩∘ (𝔉⦇ObjMap⦈) = set {a}"
by (auto intro: 𝔉.ObjMap.vsv_vdomain_vsingleton_vrange_vsingleton)
with 𝔅.smc_Obj_vsubset_Vset 𝔉.smcf_ObjMap_vrange have [simp]: "a ∈⇩∘ Vset α"
by auto
from 𝔉.smcf_ObjMap_vrange have "set {a} ⊆⇩∘ 𝔅⦇Obj⦈" by simp
moreover have "𝔅⦇Obj⦈ ⊆⇩∘ set {a}"
proof(rule ccontr)
assume "¬ 𝔅⦇Obj⦈ ⊆⇩∘ set {a}"
then obtain b where ba: "b ≠ a" and b: "b ∈⇩∘ 𝔅⦇Obj⦈" by force
define 𝔊 where "𝔊 = [set {⟨0, b⟩}, 0, smc_10 0, 𝔅]⇩∘"
have 𝔊_components:
"𝔊⦇ObjMap⦈ = set {⟨0, b⟩}"
"𝔊⦇ArrMap⦈ = 0"
"𝔊⦇HomDom⦈ = smc_10 0"
"𝔊⦇HomCod⦈ = 𝔅"
unfolding 𝔊_def dghm_field_simps by (simp_all add: nat_omega_simps)
have 𝔊: "𝔊 : smc_10 0 ↦↦⇩S⇩M⇩C⇘α⇙ 𝔅"
proof(rule is_semifunctorI, unfold 𝔊_components smc_10_components)
show "vfsequence 𝔊" unfolding 𝔊_def by auto
show "vcard 𝔊 = 4⇩ℕ"
unfolding 𝔊_def by (auto simp: nat_omega_simps)
show "smcf_dghm 𝔊 : smc_dg (smc_10 0) ↦↦⇩D⇩G⇘α⇙ smc_dg 𝔅"
proof(intro is_dghmI, unfold 𝔊_components dg_10_components smc_dg_smc_10)
show "vfsequence (smcf_dghm 𝔊)" unfolding smcf_dghm_def by simp
show "vcard (smcf_dghm 𝔊) = 4⇩ℕ"
unfolding smcf_dghm_def by (simp add: nat_omega_simps)
qed
(
auto simp:
slicing_simps slicing_intros slicing_commute smc_dg_smc_10
b 𝔊_components dg_10_is_arr_iff digraph_dg_10
)
qed (auto simp: smc_cs_intros smc_10_is_arr_iff b vsubset_vsingleton_leftI)
then have 𝔊_def: "𝔊 = 𝔉" by (rule 𝔊𝔉)
have "ℛ⇩∘ (𝔊⦇ObjMap⦈) = set {b}" unfolding 𝔊_components by simp
with vrange_𝔉 ba show False unfolding 𝔊_def by simp
qed
ultimately have "𝔅⦇Obj⦈ = set {a}" by simp
with that show ?thesis by simp
qed
obtain f
where 𝔅_Arr: "𝔅⦇Arr⦈ = set {f}"
and f: "f ∈⇩∘ Vset α"
and ff_f: "f ∘⇩A⇘𝔅⇙ f = f"
proof-
from prems(2)[OF semicategory_smc_1, of 0 0] obtain 𝔉
where "𝔉 : smc_1 0 0 ↦↦⇩S⇩M⇩C⇘α⇙ 𝔅"
and "𝔊 : smc_1 0 0 ↦↦⇩S⇩M⇩C⇘α⇙ 𝔅 ⟹ 𝔊 = 𝔉"
for 𝔊
by fastforce
then interpret 𝔉: is_semifunctor α ‹smc_1 0 0› 𝔅 𝔉 by force
have "𝒟⇩∘ (𝔉⦇ObjMap⦈) = set {0}"
by (simp add: smc_cs_simps smc_1_components)
then obtain a' where "ℛ⇩∘ (𝔉⦇ObjMap⦈) = set {a'}"
by (auto intro: 𝔉.ObjMap.vsv_vdomain_vsingleton_vrange_vsingleton)
with 𝔉.smcf_ObjMap_vrange have "ℛ⇩∘ (𝔉⦇ObjMap⦈) = set {a}"
by (auto simp: 𝔅_Obj)
have vdomain_𝔉: "𝒟⇩∘ (𝔉⦇ArrMap⦈) = set {0}"
by (simp add: smc_cs_simps smc_1_components)
then obtain f where vrange_𝔉[simp]: "ℛ⇩∘ (𝔉⦇ArrMap⦈) = set {f}"
by (auto intro: 𝔉.ArrMap.vsv_vdomain_vsingleton_vrange_vsingleton)
with 𝔅.smc_Arr_vsubset_Vset 𝔉.smcf_ArrMap_vrange have [simp]: "f ∈⇩∘ Vset α"
by auto
from 𝔉.smcf_ArrMap_vrange have f_ss_𝔅: "set {f} ⊆⇩∘ 𝔅⦇Arr⦈" by simp
then have "f ∈⇩∘ 𝔅⦇Arr⦈" by auto
then have f: "f : a ↦⇘𝔅⇙ a"
by (metis 𝔅_Obj 𝔅.smc_is_arrD(2,3) is_arrI vsingleton_iff)
from vdomain_𝔉 𝔉.ArrMap.vsv_value have [simp]: "𝔉⦇ArrMap⦈⦇0⦈ = f" by auto
from 𝔉.smcf_is_arr_HomCod(2) have [simp]: "𝔉⦇ObjMap⦈⦇0⦈ = a"
by (auto simp: smc_1_is_arr_iff 𝔅_Obj)
have "𝔉⦇ArrMap⦈⦇0⦈ ∘⇩A⇘𝔅⇙ 𝔉⦇ArrMap⦈⦇0⦈ = 𝔉⦇ArrMap⦈⦇0⦈"
by (metis smc_1_Comp_app 𝔉.smcf_ArrMap_Comp smc_1_is_arr_iff)
then have ff_f[simp]: "f ∘⇩A⇘𝔅⇙ f = f" by simp
have id_𝔅: "smcf_id 𝔅 : 𝔅 ↦↦⇩S⇩M⇩C⇘α⇙ 𝔅"
by (simp add: 𝔅.smc_smcf_id_is_semifunctor)
interpret id_𝔅: is_semifunctor α 𝔅 𝔅 ‹smcf_id 𝔅› by (rule id_𝔅)
from prems(2)[OF 𝔅.semicategory_axioms] have
"𝔊 : 𝔅 ↦↦⇩S⇩M⇩C⇘α⇙ 𝔅 ⟹ 𝔊 = smcf_id 𝔅" for 𝔊
by (clarsimp simp: id_𝔅.is_semifunctor_axioms)
moreover from f have "smcf_const 𝔅 𝔅 a f : 𝔅 ↦↦⇩S⇩M⇩C⇘α⇙ 𝔅"
by (intro smcf_const_is_semifunctor) (auto intro: smc_cs_intros)
ultimately have const_eq_id: "smcf_const 𝔅 𝔅 a f = smcf_id 𝔅" by simp
have "𝔅⦇Arr⦈ ⊆⇩∘ set {f}"
proof(rule ccontr)
assume "¬𝔅⦇Arr⦈ ⊆⇩∘ set {f}"
then obtain g where gf: "g ≠ f" and g: "g ∈⇩∘ 𝔅⦇Arr⦈" by force
have g: "g : a ↦⇘𝔅⇙ a"
proof(intro is_arrI)
from g 𝔅_Obj show "𝔅⦇Dom⦈⦇g⦈ = a"
by (metis 𝔅.smc_is_arrD(2) is_arr_def vsingleton_iff)
from g 𝔅_Obj show "𝔅⦇Cod⦈⦇g⦈ = a"
by (metis 𝔅.smc_is_arrD(3) is_arr_def vsingleton_iff)
qed (auto simp: g)
then have "smcf_const 𝔅 𝔅 a f⦇ArrMap⦈⦇g⦈ = f"
by (cs_concl cs_simp: smc_cs_simps cs_intro: smc_cs_intros)
moreover from g have "smcf_id 𝔅⦇ArrMap⦈⦇g⦈ = g"
by (cs_concl cs_simp: smc_cs_simps cs_intro: smc_cs_intros)
ultimately show False using const_eq_id by (simp add: gf)
qed
with f_ss_𝔅 have "𝔅⦇Arr⦈ = set {f}" by simp
with that show ?thesis by simp
qed
have "𝔅 = smc_1 a f"
proof(rule smc_eqI [of α], unfold smc_1_components)
show "𝔅⦇Obj⦈ = set {a}" by (simp add: 𝔅_Obj)
moreover show "𝔅⦇Arr⦈ = set {f}" by (simp add: 𝔅_Arr)
ultimately have dom: "𝔅⦇Dom⦈⦇f⦈ = a" and cod: "𝔅⦇Cod⦈⦇f⦈ = a"
by (metis 𝔅.smc_is_arrE is_arr_def vsingleton_iff)+
have "𝒟⇩∘ (𝔅⦇Dom⦈) = set {f}" by (simp add: 𝔅_Arr smc_cs_simps)
moreover from 𝔅.Dom.vsv_vrange_vempty 𝔅.smc_Dom_vdomain 𝔅.smc_Dom_vrange
have "ℛ⇩∘ (𝔅⦇Dom⦈) = set {a}"
by (fastforce simp: 𝔅_Arr 𝔅_Obj)
ultimately show "𝔅⦇Dom⦈ = set {⟨f, a⟩}"
using assms 𝔅.Dom.vsv_vdomain_vrange_vsingleton by simp
have "𝒟⇩∘ (𝔅⦇Cod⦈) = set {f}" by (simp add: 𝔅_Arr smc_cs_simps)
moreover from 𝔅.Cod.vsv_vrange_vempty 𝔅.smc_Cod_vdomain 𝔅.smc_Cod_vrange
have "ℛ⇩∘ (𝔅⦇Cod⦈) = set {a}"
by (fastforce simp: 𝔅_Arr 𝔅_Obj)
ultimately show "𝔅⦇Cod⦈ = set {⟨f, a⟩}"
using assms 𝔅.Cod.vsv_vdomain_vrange_vsingleton by simp
show "𝔅⦇Comp⦈ = set {⟨[f, f]⇩∘, f⟩}"
proof(rule vsv_eqI)
show [simp]: "𝒟⇩∘ (𝔅⦇Comp⦈) = 𝒟⇩∘ (set {⟨[f, f]⇩∘, f⟩})"
unfolding vdomain_vsingleton
proof(rule vsubset_antisym)
from 𝔅.Comp.pnop_vdomain show "𝒟⇩∘ (𝔅⦇Comp⦈) ⊆⇩∘ set {[f, f]⇩∘}"
by (auto simp: 𝔅_Arr intro: smc_cs_intros)
from 𝔅_Arr dom cod is_arrI show "set {[f, f]⇩∘} ⊆⇩∘ 𝒟⇩∘ (𝔅⦇Comp⦈)"
by (metis 𝔅.smc_Comp_vdomainI vsingletonI vsubset_vsingleton_leftI)
qed
from ff_f show "a ∈⇩∘ 𝒟⇩∘ (𝔅⦇Comp⦈) ⟹ 𝔅⦇Comp⦈⦇a⦈ = set {⟨[f, f]⇩∘, f⟩}⦇a⦈"
for a
by simp
qed auto
qed (auto intro: smc_cs_intros a f semicategory_smc_1)
with a f that show ?thesis by auto
qed
text‹\newpage›
end
Theory CZH_SMC_Rel
section‹‹Rel› as a semicategory›
theory CZH_SMC_Rel
imports
CZH_DG_Rel
CZH_SMC_Semifunctor
CZH_SMC_Small_Semicategory
begin
subsection‹Background›
text‹
The methodology chosen for the exposition
of ‹Rel› as a semicategory is analogous to the
one used in the previous chapter for the exposition of ‹Rel› as a digraph.
The general references for this section are Chapter I-7
in \cite{mac_lane_categories_2010} and nLab
\cite{noauthor_nlab_nodate}\footnote{
\url{https://ncatlab.org/nlab/show/Rel}
}.
›
named_theorems smc_Rel_cs_simps
named_theorems smc_Rel_cs_intros
lemmas (in arr_Rel) [smc_Rel_cs_simps] =
dg_Rel_shared_cs_simps
lemmas [smc_Rel_cs_simps] =
dg_Rel_shared_cs_simps
arr_Rel.arr_Rel_length
arr_Rel_comp_Rel_id_Rel_left
arr_Rel_comp_Rel_id_Rel_right
arr_Rel.arr_Rel_converse_Rel_converse_Rel
arr_Rel_converse_Rel_eq_iff
arr_Rel_converse_Rel_comp_Rel
arr_Rel_comp_Rel_converse_Rel_left_if_v11
arr_Rel_comp_Rel_converse_Rel_right_if_v11
lemmas [smc_Rel_cs_intros] =
dg_Rel_shared_cs_intros
arr_Rel_comp_Rel
arr_Rel.arr_Rel_converse_Rel
subsection‹‹Rel› as a semicategory›
subsubsection‹Definition and elementary properties›
definition smc_Rel :: "V ⇒ V"
where "smc_Rel α =
[
Vset α,
set {T. arr_Rel α T},
(λT∈⇩∘set {T. arr_Rel α T}. T⦇ArrDom⦈),
(λT∈⇩∘set {T. arr_Rel α T}. T⦇ArrCod⦈),
(λST∈⇩∘composable_arrs (dg_Rel α). ST⦇0⦈ ∘⇩R⇩e⇩l ST⦇1⇩ℕ⦈)
]⇩∘"
text‹Components.›
lemma smc_Rel_components:
shows "smc_Rel α⦇Obj⦈ = Vset α"
and "smc_Rel α⦇Arr⦈ = set {T. arr_Rel α T}"
and "smc_Rel α⦇Dom⦈ = (λT∈⇩∘set {T. arr_Rel α T}. T⦇ArrDom⦈)"
and "smc_Rel α⦇Cod⦈ = (λT∈⇩∘set {T. arr_Rel α T}. T⦇ArrCod⦈)"
and "smc_Rel α⦇Comp⦈ = (λST∈⇩∘composable_arrs (dg_Rel α). ST⦇0⦈ ∘⇩R⇩e⇩l ST⦇1⇩ℕ⦈)"
unfolding smc_Rel_def dg_field_simps by (simp_all add: nat_omega_simps)
text‹Slicing.›
lemma smc_dg_smc_Rel: "smc_dg (smc_Rel α) = dg_Rel α"
proof(rule vsv_eqI)
show "vsv (smc_dg (smc_Rel α))" unfolding smc_dg_def by auto
show "vsv (dg_Rel α)" unfolding dg_Rel_def by auto
have dom_lhs: "𝒟⇩∘ (smc_dg (smc_Rel α)) = 4⇩ℕ"
unfolding smc_dg_def by (simp add: nat_omega_simps)
have dom_rhs: "𝒟⇩∘ (dg_Rel α) = 4⇩ℕ"
unfolding dg_Rel_def by (simp add: nat_omega_simps)
show "𝒟⇩∘ (smc_dg (smc_Rel α)) = 𝒟⇩∘ (dg_Rel α)"
unfolding dom_lhs dom_rhs by simp
show "a ∈⇩∘ 𝒟⇩∘ (smc_dg (smc_Rel α)) ⟹ smc_dg (smc_Rel α)⦇a⦈ = dg_Rel α⦇a⦈"
for a
by
(
unfold dom_lhs,
elim_in_numeral,
unfold smc_dg_def dg_field_simps smc_Rel_def dg_Rel_def
)
(auto simp: nat_omega_simps)
qed
lemmas_with [folded smc_dg_smc_Rel, unfolded slicing_simps]:
smc_Rel_Obj_iff = dg_Rel_Obj_iff
and smc_Rel_Arr_iff[smc_Rel_cs_simps] = dg_Rel_Arr_iff
and smc_Rel_Dom_vsv[smc_Rel_cs_intros] = dg_Rel_Dom_vsv
and smc_Rel_Dom_vdomain[smc_Rel_cs_simps] = dg_Rel_Dom_vdomain
and smc_Rel_Dom_app[smc_Rel_cs_simps] = dg_Rel_Dom_app
and smc_Rel_Dom_vrange = dg_Rel_Dom_vrange
and smc_Rel_Cod_vsv[smc_Rel_cs_intros] = dg_Rel_Cod_vsv
and smc_Rel_Cod_vdomain[smc_Rel_cs_simps] = dg_Rel_Cod_vdomain
and smc_Rel_Cod_app[smc_Rel_cs_simps] = dg_Rel_Cod_app
and smc_Rel_Cod_vrange = dg_Rel_Cod_vrange
and smc_Rel_is_arrI[smc_Rel_cs_intros] = dg_Rel_is_arrI
and smc_Rel_is_arrD = dg_Rel_is_arrD
and smc_Rel_is_arrE = dg_Rel_is_arrE
lemmas [smc_cs_simps] = smc_Rel_is_arrD(2,3)
lemmas_with (in 𝒵) [folded smc_dg_smc_Rel, unfolded slicing_simps]:
smc_Rel_Hom_vifunion_in_Vset = dg_Rel_Hom_vifunion_in_Vset
and smc_Rel_incl_Rel_is_arr = dg_Rel_incl_Rel_is_arr
and smc_Rel_incl_Rel_is_arr'[smc_Rel_cs_intros] = dg_Rel_incl_Rel_is_arr'
lemmas [smc_Rel_cs_intros] = 𝒵.smc_Rel_incl_Rel_is_arr'
subsubsection‹Composable arrows›
lemma smc_Rel_composable_arrs_dg_Rel:
"composable_arrs (dg_Rel α) = composable_arrs (smc_Rel α)"
unfolding composable_arrs_def smc_dg_smc_Rel[symmetric] slicing_simps by simp
lemma smc_Rel_Comp:
"smc_Rel α⦇Comp⦈ = (λST∈⇩∘composable_arrs (smc_Rel α). ST⦇0⦈ ∘⇩R⇩e⇩l ST⦇1⇩ℕ⦈)"
unfolding smc_Rel_components smc_Rel_composable_arrs_dg_Rel ..
subsubsection‹Composition›
lemma smc_Rel_Comp_app[smc_Rel_cs_simps]:
assumes "S : b ↦⇘smc_Rel α⇙ c" and "T : a ↦⇘smc_Rel α⇙ b"
shows "S ∘⇩A⇘smc_Rel α⇙ T = S ∘⇩R⇩e⇩l T"
proof-
from assms have "[S, T]⇩∘ ∈⇩∘ composable_arrs (smc_Rel α)"
by (auto intro: smc_cs_intros)
then show "S ∘⇩A⇘smc_Rel α⇙ T = S ∘⇩R⇩e⇩l T"
unfolding smc_Rel_Comp by (simp add: nat_omega_simps)
qed
lemma smc_Rel_Comp_vdomain: "𝒟⇩∘ (smc_Rel α⦇Comp⦈) = composable_arrs (smc_Rel α)"
unfolding smc_Rel_Comp by simp
lemma (in 𝒵) smc_CAT_Comp_vrange:
"ℛ⇩∘ (smc_Rel α⦇Comp⦈) ⊆⇩∘ set {T. arr_Rel α T}"
proof(rule vsubsetI)
interpret digraph α ‹smc_dg (smc_Rel α)›
unfolding smc_dg_smc_Rel by (simp add: digraph_dg_Rel)
fix R assume "R ∈⇩∘ ℛ⇩∘ (smc_Rel α⦇Comp⦈)"
then obtain ST
where R_def: "R = smc_Rel α⦇Comp⦈⦇ST⦈"
and "ST ∈⇩∘ 𝒟⇩∘ (smc_Rel α⦇Comp⦈)"
unfolding smc_Rel_components by (auto intro: smc_cs_intros)
then obtain S T a b c
where "ST = [S, T]⇩∘"
and S: "S : b ↦⇘smc_Rel α⇙ c"
and T: "T : a ↦⇘smc_Rel α⇙ b"
by (auto simp: smc_Rel_Comp_vdomain)
with R_def have R_def': "R = S ∘⇩A⇘smc_Rel α⇙ T" by simp
note S_D = dg_is_arrD(1)[unfolded slicing_simps, OF S]
note T_D = dg_is_arrD(1)[unfolded slicing_simps, OF T]
from S_D T_D have "arr_Rel α S" "arr_Rel α T"
by (simp_all add: smc_Rel_components)
from this show "R ∈⇩∘ set {T. arr_Rel α T}"
unfolding R_def' smc_Rel_Comp_app[OF S T] by (auto simp: arr_Rel_comp_Rel)
qed
subsubsection‹‹Rel› is a semicategory›
lemma (in 𝒵) semicategory_smc_Rel: "semicategory α (smc_Rel α)"
proof(rule semicategoryI, unfold smc_dg_smc_Rel)
show "vfsequence (smc_Rel α)" unfolding smc_Rel_def by simp
show "vcard (smc_Rel α) = 5⇩ℕ"
unfolding smc_Rel_def by (simp add: nat_omega_simps)
show "gf ∈⇩∘ 𝒟⇩∘ (smc_Rel α⦇Comp⦈) ⟷
(∃g f b c a. gf = [g, f]⇩∘ ∧ g : b ↦⇘smc_Rel α⇙ c ∧ f : a ↦⇘smc_Rel α⇙ b)"
for gf
unfolding smc_Rel_Comp_vdomain by (auto intro: composable_arrsI)
show "g ∘⇩A⇘smc_Rel α⇙ f : a ↦⇘smc_Rel α⇙ c"
if "g : b ↦⇘smc_Rel α⇙ c" and "f : a ↦⇘smc_Rel α⇙ b" for g b c f a
proof-
from that have "arr_Rel α g" and "arr_Rel α f"
by (auto simp: smc_Rel_is_arrD(1))
with that show ?thesis
by
(
cs_concl
cs_simp: smc_cs_simps smc_Rel_cs_simps cs_intro: smc_Rel_cs_intros
)
qed
show "h ∘⇩A⇘smc_Rel α⇙ g ∘⇩A⇘smc_Rel α⇙ f = h ∘⇩A⇘smc_Rel α⇙ (g ∘⇩A⇘smc_Rel α⇙ f)"
if "h : c ↦⇘smc_Rel α⇙ d"
and "g : b ↦⇘smc_Rel α⇙ c"
and "f : a ↦⇘smc_Rel α⇙ b"
for h c d g b f a
proof-
from that have "arr_Rel α h" and "arr_Rel α g" and "arr_Rel α f"
by (auto simp: smc_Rel_is_arrD(1))
with that show ?thesis
by
(
cs_concl
cs_simp: smc_cs_simps smc_Rel_cs_simps
cs_intro: smc_Rel_cs_intros
)
qed
qed (auto simp: digraph_dg_Rel smc_Rel_components)
subsection‹Canonical dagger for ‹Rel››
subsubsection‹Definition and elementary properties›
definition smcf_dag_Rel :: "V ⇒ V" (‹†⇩S⇩M⇩C⇩.⇩R⇩e⇩l›)
where "†⇩S⇩M⇩C⇩.⇩R⇩e⇩l α =
[
vid_on (smc_Rel α⦇Obj⦈),
VLambda (smc_Rel α⦇Arr⦈) converse_Rel,
op_smc (smc_Rel α),
smc_Rel α
]⇩∘"
text‹Components.›
lemma smcf_dag_Rel_components:
shows "†⇩S⇩M⇩C⇩.⇩R⇩e⇩l α⦇ObjMap⦈ = vid_on (smc_Rel α⦇Obj⦈)"
and "†⇩S⇩M⇩C⇩.⇩R⇩e⇩l α⦇ArrMap⦈ = VLambda (smc_Rel α⦇Arr⦈) converse_Rel"
and "†⇩S⇩M⇩C⇩.⇩R⇩e⇩l α⦇HomDom⦈ = op_smc (smc_Rel α)"
and "†⇩S⇩M⇩C⇩.⇩R⇩e⇩l α⦇HomCod⦈ = smc_Rel α"
unfolding smcf_dag_Rel_def dghm_field_simps by (simp_all add: nat_omega_simps)
text‹Slicing.›
lemma smcf_dghm_smcf_dag_Rel: "smcf_dghm (†⇩S⇩M⇩C⇩.⇩R⇩e⇩l α) = †⇩D⇩G⇩.⇩R⇩e⇩l α"
proof(rule vsv_eqI)
show "vsv (smcf_dghm (†⇩S⇩M⇩C⇩.⇩R⇩e⇩l α))" unfolding smcf_dghm_def by auto
show "vsv (†⇩D⇩G⇩.⇩R⇩e⇩l α)" unfolding dghm_dag_Rel_def by auto
have dom_lhs: "𝒟⇩∘ (smcf_dghm (†⇩S⇩M⇩C⇩.⇩R⇩e⇩l α)) = 4⇩ℕ"
unfolding smcf_dghm_def by (simp add: nat_omega_simps)
have dom_rhs: "𝒟⇩∘ (†⇩D⇩G⇩.⇩R⇩e⇩l α) = 4⇩ℕ"
unfolding dghm_dag_Rel_def by (simp add: nat_omega_simps)
show "𝒟⇩∘ (smcf_dghm (†⇩S⇩M⇩C⇩.⇩R⇩e⇩l α)) = 𝒟⇩∘ (†⇩D⇩G⇩.⇩R⇩e⇩l α)"
unfolding dom_lhs dom_rhs by simp
show "a ∈⇩∘ 𝒟⇩∘ (smcf_dghm (†⇩S⇩M⇩C⇩.⇩R⇩e⇩l α)) ⟹
smcf_dghm (†⇩S⇩M⇩C⇩.⇩R⇩e⇩l α)⦇a⦈ = †⇩D⇩G⇩.⇩R⇩e⇩l α⦇a⦈"
for a
by
(
unfold dom_lhs,
elim_in_numeral,
unfold dghm_field_simps[symmetric],
unfold
smc_dg_smc_Rel
slicing_commute[symmetric]
smcf_dghm_components
dghm_dag_Rel_components
smcf_dag_Rel_components
dg_Rel_components
smc_Rel_components
)
simp_all
qed
lemmas_with [
folded smc_dg_smc_Rel smcf_dghm_smcf_dag_Rel,
unfolded slicing_simps
]:
smcf_dag_Rel_ObjMap_vsv[smc_Rel_cs_intros] = dghm_dag_Rel_ObjMap_vsv
and smcf_dag_Rel_ObjMap_vdomain[smc_Rel_cs_simps] =
dghm_dag_Rel_ObjMap_vdomain
and smcf_dag_Rel_ObjMap_app[smc_Rel_cs_simps] = dghm_dag_Rel_ObjMap_app
and smcf_dag_Rel_ObjMap_vrange[smc_Rel_cs_simps] = dghm_dag_Rel_ObjMap_vrange
and smcf_dag_Rel_ArrMap_vsv[smc_Rel_cs_intros] = dghm_dag_Rel_ArrMap_vsv
and smcf_dag_Rel_ArrMap_vdomain[smc_Rel_cs_simps] = dghm_dag_Rel_ArrMap_vdomain
and smcf_dag_Rel_ArrMap_app[smc_Rel_cs_simps] = dghm_dag_Rel_ArrMap_app
and smcf_dag_Rel_ArrMap_vrange[smc_Rel_cs_simps] = dghm_dag_Rel_ArrMap_vrange
lemmas_with (in 𝒵) [
folded smc_dg_smc_Rel smcf_dghm_smcf_dag_Rel, unfolded slicing_simps
]:
smcf_dag_Rel_app_is_arr = dghm_dag_Rel_ArrMap_app_is_arr
subsubsection‹Canonical dagger is a contravariant isomorphism of ‹Rel››
lemma (in 𝒵) smcf_dag_Rel_is_iso_semifunctor:
"†⇩S⇩M⇩C⇩.⇩R⇩e⇩l α : op_smc (smc_Rel α) ↦↦⇩S⇩M⇩C⇩.⇩i⇩s⇩o⇘α⇙ smc_Rel α"
proof(rule is_iso_semifunctorI)
interpret dag: is_iso_dghm α ‹op_dg (dg_Rel α)› ‹dg_Rel α› ‹†⇩D⇩G⇩.⇩R⇩e⇩l α›
by (rule dghm_dag_Rel_is_iso_dghm)
interpret Rel: semicategory α ‹smc_Rel α›
by (rule semicategory_smc_Rel)
show "†⇩S⇩M⇩C⇩.⇩R⇩e⇩l α : op_smc (smc_Rel α) ↦↦⇩S⇩M⇩C⇘α⇙ smc_Rel α"
proof
(
rule is_semifunctorI,
unfold
smc_dg_smc_Rel
smcf_dghm_smcf_dag_Rel
smc_op_simps
slicing_commute[symmetric]
smcf_dag_Rel_components(3,4)
)
show "vfsequence (†⇩S⇩M⇩C⇩.⇩R⇩e⇩l α)"
unfolding smcf_dag_Rel_def by (simp add: nat_omega_simps)
show "vcard (†⇩S⇩M⇩C⇩.⇩R⇩e⇩l α) = 4⇩ℕ"
unfolding smcf_dag_Rel_def by (simp add: nat_omega_simps)
show "†⇩S⇩M⇩C⇩.⇩R⇩e⇩l α⦇ArrMap⦈⦇f ∘⇩A⇘smc_Rel α⇙ g⦈ =
†⇩S⇩M⇩C⇩.⇩R⇩e⇩l α⦇ArrMap⦈⦇g⦈ ∘⇩A⇘smc_Rel α⇙ †⇩S⇩M⇩C⇩.⇩R⇩e⇩l α⦇ArrMap⦈⦇f⦈"
if "g : c ↦⇘smc_Rel α⇙ b" and "f : b ↦⇘smc_Rel α⇙ a"
for g b c f a
proof-
from that have "arr_Rel α g" and "arr_Rel α f"
by (auto simp: smc_Rel_is_arrD(1))
with that show ?thesis
by
(
cs_concl
cs_simp: smc_cs_simps smc_Rel_cs_simps
cs_intro: smc_Rel_cs_intros
)
qed
qed (auto simp: dg_cs_intros smc_op_intros semicategory_smc_Rel)
show "smcf_dghm (†⇩S⇩M⇩C⇩.⇩R⇩e⇩l α) :
smc_dg (op_smc (smc_Rel α)) ↦↦⇩D⇩G⇩.⇩i⇩s⇩o⇘α⇙ smc_dg (smc_Rel α)"
by
(
simp add:
smc_dg_smc_Rel
smcf_dghm_smcf_dag_Rel
smc_op_simps
slicing_simps
slicing_commute[symmetric]
dghm_dag_Rel_is_iso_dghm
)
qed
subsubsection‹Further properties of the canonical dagger›
lemma (in 𝒵) smcf_cn_comp_smcf_dag_Rel_smcf_dag_Rel:
"†⇩S⇩M⇩C⇩.⇩R⇩e⇩l α ⇩S⇩M⇩C⇩F∘ †⇩S⇩M⇩C⇩.⇩R⇩e⇩l α = smcf_id (smc_Rel α)"
proof(rule smcf_dghm_eqI)
interpret semicategory α ‹smc_Rel α› by (simp add: semicategory_smc_Rel)
from smcf_dag_Rel_is_iso_semifunctor have dag:
"†⇩S⇩M⇩C⇩.⇩R⇩e⇩l α : op_smc (smc_Rel α) ↦↦⇩S⇩M⇩C⇘α⇙ smc_Rel α"
by (simp add: is_iso_semifunctor.axioms(1))
from smcf_cn_comp_is_semifunctor[OF semicategory_axioms dag dag] show
"†⇩S⇩M⇩C⇩.⇩R⇩e⇩l α ⇩S⇩M⇩C⇩F∘ †⇩S⇩M⇩C⇩.⇩R⇩e⇩l α : smc_Rel α ↦↦⇩S⇩M⇩C⇘α⇙ smc_Rel α" .
show "smcf_id (smc_Rel α) : smc_Rel α ↦↦⇩S⇩M⇩C⇘α⇙ smc_Rel α"
by (auto simp: smc_smcf_id_is_semifunctor)
show "smcf_dghm (†⇩S⇩M⇩C⇩.⇩R⇩e⇩l α ⇩S⇩M⇩C⇩F∘ †⇩S⇩M⇩C⇩.⇩R⇩e⇩l α) = smcf_dghm (smcf_id (smc_Rel α))"
unfolding
slicing_simps slicing_commute[symmetric]
smc_dg_smc_Rel
smcf_dghm_smcf_dag_Rel
by (simp add: dghm_cn_comp_dghm_dag_Rel_dghm_dag_Rel)
qed simp_all
lemma (in 𝒵) smcf_dag_Rel_ArrMap_smc_Rel_Comp:
assumes "S : b ↦⇘smc_Rel α⇙ c" and "T : a ↦⇘smc_Rel α⇙ b"
shows "†⇩S⇩M⇩C⇩.⇩R⇩e⇩l α⦇ArrMap⦈⦇S ∘⇩A⇘smc_Rel α⇙ T⦈ =
†⇩S⇩M⇩C⇩.⇩R⇩e⇩l α⦇ArrMap⦈⦇T⦈ ∘⇩A⇘smc_Rel α⇙ †⇩S⇩M⇩C⇩.⇩R⇩e⇩l α⦇ArrMap⦈⦇S⦈"
proof-
from assms have "arr_Rel α S" and "arr_Rel α T"
by (auto simp: smc_Rel_is_arrD(1))
with assms show ?thesis
by
(
cs_concl
cs_simp: smc_cs_simps smc_Rel_cs_simps cs_intro: smc_Rel_cs_intros
)
qed
subsection‹Monic arrow and epic arrow›
text‹
The conditions for an arrow of ‹Rel› to be either monic or epic are
outlined in nLab \cite{noauthor_nlab_nodate}\footnote{
\url{https://ncatlab.org/nlab/show/Rel}
}.
›
context 𝒵
begin
context
begin
private lemma smc_Rel_is_monic_arr_vsubset:
assumes "T : A ↦⇘smc_Rel α⇙ B"
and "R : A' ↦⇘smc_Rel α⇙ A"
and "S : A' ↦⇘smc_Rel α⇙ A"
and "T ∘⇩A⇘smc_Rel α⇙ R = T ∘⇩A⇘smc_Rel α⇙ S"
and "⋀y z X.
⟦ y ⊆⇩∘ A; z ⊆⇩∘ A; T⦇ArrVal⦈ `⇩∘ y = X; T⦇ArrVal⦈ `⇩∘ z = X ⟧ ⟹ y = z"
shows "R⦇ArrVal⦈ ⊆⇩∘ S⦇ArrVal⦈"
proof-
interpret Rel: semicategory α ‹smc_Rel α› by (rule semicategory_smc_Rel)
interpret R: arr_Rel α R
rewrites "R⦇ArrDom⦈ = A'" and "R⦇ArrCod⦈ = A"
using assms(2)
by (all‹elim Rel.smc_is_arrE›) (simp_all add: smc_Rel_components)
interpret S: arr_Rel α S
rewrites "S⦇ArrDom⦈ = A'" and "S⦇ArrCod⦈ = A"
using assms(3)
by (all‹elim Rel.smc_is_arrE›) (simp_all add: smc_Rel_components)
from assms(4) have "(T ∘⇩A⇘smc_Rel α⇙ R)⦇ArrVal⦈ = (T ∘⇩A⇘smc_Rel α⇙ S)⦇ArrVal⦈"
by simp
then have eq: "T⦇ArrVal⦈ ∘⇩∘ R⦇ArrVal⦈ = T⦇ArrVal⦈ ∘⇩∘ S⦇ArrVal⦈"
unfolding
smc_Rel_Comp_app[OF assms(1,2)]
smc_Rel_Comp_app[OF assms(1,3)]
comp_Rel_components
by simp
show "R⦇ArrVal⦈ ⊆⇩∘ S⦇ArrVal⦈"
proof(rule vsubsetI)
fix ab assume ab[intro]: "ab ∈⇩∘ R⦇ArrVal⦈"
with R.ArrVal.vbrelation obtain a b where ab_def: "ab = ⟨a, b⟩" by auto
with ab R.arr_Rel_ArrVal_vrange have "a ∈⇩∘ 𝒟⇩∘ (R⦇ArrVal⦈)" and "b ∈⇩∘ A"
by auto
define B' and C' where "B' = R⦇ArrVal⦈ `⇩∘ set {a}" and "C' = T⦇ArrVal⦈ `⇩∘ B'"
have ne_C': "C' ≠ 0"
proof(rule ccontr, unfold not_not)
assume prems: "C' = 0"
from ab have "b ∈⇩∘ B'" unfolding ab_def B'_def by simp
with C'_def[unfolded prems] have b0: "T⦇ArrVal⦈ `⇩∘ set {b} = 0" by auto
from assms(5)[OF _ _ b0, of 0] ‹b ∈⇩∘ A› show False by auto
qed
have cac''[intro, simp]:
"c ∈⇩∘ C' ⟹ ⟨a, c⟩ ∈⇩∘ T⦇ArrVal⦈ ∘⇩∘ S⦇ArrVal⦈" for c
unfolding eq[symmetric] C'_def B'_def
by (metis vcomp_vimage vimage_vsingleton_iff)
define A'' where "A'' = (T⦇ArrVal⦈ ∘⇩∘ S⦇ArrVal⦈) -`⇩∘ C'"
define B'' where "B'' = S⦇ArrVal⦈ `⇩∘ set {a}"
define C'' where "C'' = T⦇ArrVal⦈ `⇩∘ B''"
have a'': "a ∈⇩∘ A''"
proof-
from ne_C' obtain c' where [intro]: "c' ∈⇩∘ C'"
by (auto intro!: vsubset_antisym)
then have "⟨a, c'⟩ ∈⇩∘ T⦇ArrVal⦈ ∘⇩∘ S⦇ArrVal⦈" by simp
then show ?thesis unfolding A''_def by auto
qed
have "C' ⊆⇩∘ C''"
unfolding C''_def B''_def A''_def C'_def B'_def
by (rule vsubsetI) (metis eq vcomp_vimage)
have "C' = C''"
proof(rule ccontr)
assume "C' ≠ C''"
with ‹C' ⊆⇩∘ C''› obtain c' where c': "c' ∈⇩∘ C'' -⇩∘ C'"
by (auto intro!: vsubset_antisym)
then obtain b'' where "b'' ∈⇩∘ B''" and "⟨b'', c'⟩ ∈⇩∘ T⦇ArrVal⦈"
unfolding C''_def by auto
then have "⟨a, c'⟩ ∈⇩∘ T⦇ArrVal⦈ ∘⇩∘ R⦇ArrVal⦈" unfolding eq B''_def by auto
with c' show False unfolding B'_def C'_def by auto
qed
then have "T⦇ArrVal⦈ `⇩∘ B'' = T⦇ArrVal⦈ `⇩∘ B'" by (simp add: C''_def C'_def)
moreover have "B' ⊆⇩∘ A" and "B'' ⊆⇩∘ A"
using R.arr_Rel_ArrVal_vrange S.arr_Rel_ArrVal_vrange
unfolding B'_def B''_def
by auto
ultimately have "B'' = B'" by (simp add: assms(5))
with ab have "b ∈⇩∘ B''" unfolding B'_def ab_def by simp
then show "ab ∈⇩∘ S⦇ArrVal⦈" unfolding ab_def B''_def by simp
qed
qed
lemma smc_Rel_is_monic_arrI:
assumes "T : A ↦⇘smc_Rel α⇙ B"
and "⋀y z X. ⟦ y ⊆⇩∘ A; z ⊆⇩∘ A; T⦇ArrVal⦈ `⇩∘ y = X; T⦇ArrVal⦈ `⇩∘ z = X ⟧ ⟹
y = z"
shows "T : A ↦⇩m⇩o⇩n⇘smc_Rel α⇙ B"
proof(rule is_monic_arrI)
interpret Rel: semicategory α ‹smc_Rel α› by (simp add: semicategory_smc_Rel)
fix R S A'
assume prems:
"R : A' ↦⇘smc_Rel α⇙ A"
"S : A' ↦⇘smc_Rel α⇙ A"
"T ∘⇩A⇘smc_Rel α⇙ R = T ∘⇩A⇘smc_Rel α⇙ S"
interpret T: arr_Rel α T
rewrites "T⦇ArrDom⦈ = A" and "T⦇ArrCod⦈ = B"
using assms(1)
by (all‹elim Rel.smc_is_arrE›) (simp_all add: smc_Rel_components)
interpret R: arr_Rel α R
rewrites [simp]: "R⦇ArrDom⦈ = A'" and [simp]: "R⦇ArrCod⦈ = A"
using prems(1)
by (all‹elim Rel.smc_is_arrE›) (simp_all add: smc_Rel_components)
interpret S: arr_Rel α S
rewrites [simp]: "S⦇ArrDom⦈ = A'" and [simp]: "S⦇ArrCod⦈ = A"
using prems(2)
by (all‹elim Rel.smc_is_arrE›) (simp_all add: smc_Rel_components)
from assms prems have
"R⦇ArrVal⦈ ⊆⇩∘ S⦇ArrVal⦈" "S⦇ArrVal⦈ ⊆⇩∘ R⦇ArrVal⦈"
by (auto simp: smc_Rel_is_monic_arr_vsubset)
then show "R = S"
using R.arr_Rel_axioms S.arr_Rel_axioms
by (intro arr_Rel_eqI[of α R S]) auto
qed (rule assms(1))
end
end
lemma (in 𝒵) smc_Rel_is_monic_arrD[dest]:
assumes "T : A ↦⇩m⇩o⇩n⇘smc_Rel α⇙ B"
and "y ⊆⇩∘ A"
and "z ⊆⇩∘ A"
and "T⦇ArrVal⦈ `⇩∘ y = X"
and "T⦇ArrVal⦈ `⇩∘ z = X"
shows "y = z"
proof-
interpret Rel: semicategory α ‹smc_Rel α› by (simp add: semicategory_smc_Rel)
from assms have T: "T : A ↦⇘smc_Rel α⇙ B" by (simp add: is_monic_arr_def)
interpret T: arr_Rel α T
rewrites "T⦇ArrDom⦈ = A" and [simp]: "T⦇ArrCod⦈ = B"
using T
by (all‹elim Rel.smc_is_arrE›) (simp_all add: smc_Rel_components)
define R where "R = [set {0} ×⇩∘ y, set {0}, A]⇩∘"
define S where "S = [set {0} ×⇩∘ z, set {0}, A]⇩∘"
have R: "R : set {0} ↦⇘smc_Rel α⇙ A"
proof(intro smc_Rel_is_arrI)
show "arr_Rel α R"
unfolding R_def
proof(intro arr_Rel_vfsequenceI)
from assms(2) show "ℛ⇩∘ (set {0} ×⇩∘ y) ⊆⇩∘ A" by auto
qed (auto simp: T.arr_Rel_ArrDom_in_Vset)
qed (simp_all add: R_def arr_Rel_components)
from assms(3) have S: "S : set {0} ↦⇘smc_Rel α⇙ A"
proof(intro smc_Rel_is_arrI)
show "arr_Rel α S"
unfolding S_def
proof(intro arr_Rel_vfsequenceI)
from assms(3) show "ℛ⇩∘ (set {0} ×⇩∘ z) ⊆⇩∘ A" by auto
qed (auto simp: T.arr_Rel_ArrDom_in_Vset)
qed (simp_all add: S_def arr_Rel_components)
from assms(4) have "T ∘⇩A⇘smc_Rel α⇙ R = [set {0} ×⇩∘ X, set {0}, B]⇩∘"
unfolding smc_Rel_Comp_app[OF T R]
unfolding comp_Rel_components R_def comp_Rel_def arr_Rel_components
by (simp add: vcomp_vimage_vtimes_right)
moreover from assms have "T ∘⇩A⇘smc_Rel α⇙ S = [set {0} ×⇩∘ X, set {0}, B]⇩∘"
unfolding smc_Rel_Comp_app[OF T S]
unfolding comp_Rel_components S_def comp_Rel_def arr_Rel_components
by (simp add: vcomp_vimage_vtimes_right)
ultimately have "T ∘⇩A⇘smc_Rel α⇙ R = T ∘⇩A⇘smc_Rel α⇙ S" by simp
from R S assms(1) this have "R = S" by (elim is_monic_arrE)
then show "y = z" unfolding R_def S_def by auto
qed
lemma (in 𝒵) smc_Rel_is_monic_arr:
"T : A ↦⇩m⇩o⇩n⇘smc_Rel α⇙ B ⟷
T : A ↦⇘smc_Rel α⇙ B ∧
(
∀y z X.
y ⊆⇩∘ A ⟶
z ⊆⇩∘ A ⟶
(T⦇ArrVal⦈) `⇩∘ y = X ⟶
(T⦇ArrVal⦈) `⇩∘ z = X ⟶
y = z
)"
by (rule iffI allI impI)
(auto simp: smc_Rel_is_monic_arrD smc_Rel_is_monic_arrI)
lemma (in 𝒵) smc_Rel_is_monic_arr_is_epic_arr:
assumes "T : A ↦⇘smc_Rel α⇙ B"
and "(†⇩S⇩M⇩C⇩.⇩R⇩e⇩l α)⦇ArrMap⦈⦇T⦈ : B ↦⇩m⇩o⇩n⇘smc_Rel α⇙ A"
shows "T : A ↦⇩e⇩p⇩i⇘smc_Rel α⇙ B"
proof-
interpret is_iso_semifunctor α ‹op_smc (smc_Rel α)› ‹smc_Rel α› ‹†⇩S⇩M⇩C⇩.⇩R⇩e⇩l α›
rewrites "(op_smc ℭ')⦇Obj⦈ = ℭ'⦇Obj⦈"
and "(op_smc ℭ')⦇Arr⦈ = ℭ'⦇Arr⦈"
and "f : b ↦⇘op_smc ℭ'⇙ a ⟷ f : a ↦⇘ℭ'⇙ b"
for ℭ' f a b
unfolding smc_op_simps by (auto simp: smcf_dag_Rel_is_iso_semifunctor)
show ?thesis
proof(intro HomCod.is_epic_arrI)
show T: "T : A ↦⇘smc_Rel α⇙ B" by (rule assms(1))
fix f g a assume prems:
"f : B ↦⇘smc_Rel α⇙ a"
"g : B ↦⇘smc_Rel α⇙ a"
"f ∘⇩A⇘smc_Rel α⇙ T = g ∘⇩A⇘smc_Rel α⇙ T"
from prems(1) have "†⇩S⇩M⇩C⇩.⇩R⇩e⇩l α⦇ArrMap⦈⦇f⦈ :
†⇩S⇩M⇩C⇩.⇩R⇩e⇩l α⦇ObjMap⦈⦇a⦈ ↦⇘smc_Rel α⇙ †⇩S⇩M⇩C⇩.⇩R⇩e⇩l α⦇ObjMap⦈⦇B⦈"
by (auto intro: smc_cs_intros)
with prems(1) HomCod.smc_is_arrD(3) T have dag_f:
"†⇩S⇩M⇩C⇩.⇩R⇩e⇩l α⦇ArrMap⦈⦇f⦈ : a ↦⇘smc_Rel α⇙ B"
unfolding smcf_dag_Rel_components(1) by auto
from prems(2) have "†⇩S⇩M⇩C⇩.⇩R⇩e⇩l α⦇ArrMap⦈⦇g⦈ :
†⇩S⇩M⇩C⇩.⇩R⇩e⇩l α⦇ObjMap⦈⦇a⦈ ↦⇘smc_Rel α⇙ †⇩S⇩M⇩C⇩.⇩R⇩e⇩l α⦇ObjMap⦈⦇B⦈"
by (auto intro: smc_cs_intros)
with prems(2) have dag_g: "†⇩S⇩M⇩C⇩.⇩R⇩e⇩l α⦇ArrMap⦈⦇g⦈ : a ↦⇘smc_Rel α⇙ B"
unfolding smcf_dag_Rel_components(1)
by (metis HomCod.smc_is_arrD(3) T vid_on_eq_atI)
from prems T have
"†⇩S⇩M⇩C⇩.⇩R⇩e⇩l α⦇ArrMap⦈⦇T⦈ ∘⇩A⇘smc_Rel α⇙ †⇩S⇩M⇩C⇩.⇩R⇩e⇩l α⦇ArrMap⦈⦇f⦈ =
†⇩S⇩M⇩C⇩.⇩R⇩e⇩l α⦇ArrMap⦈⦇T⦈ ∘⇩A⇘smc_Rel α⇙ †⇩S⇩M⇩C⇩.⇩R⇩e⇩l α⦇ArrMap⦈⦇g⦈"
by (simp add: smcf_dag_Rel_ArrMap_smc_Rel_Comp[symmetric])
from is_monic_arrD(2)[OF assms(2) dag_f dag_g this] show "f = g"
by (meson prems HomDom.smc_is_arrD(1) ArrMap.v11_eq_iff)
qed
qed
lemma (in 𝒵) smc_Rel_is_epic_arr_is_monic_arr:
assumes "T : A ↦⇩e⇩p⇩i⇘smc_Rel α⇙ B"
shows "†⇩S⇩M⇩C⇩.⇩R⇩e⇩l α⦇ArrMap⦈⦇T⦈ : B ↦⇩m⇩o⇩n⇘smc_Rel α⇙ A"
proof(rule is_monic_arrI)
interpret is_iso_semifunctor α ‹op_smc (smc_Rel α)› ‹smc_Rel α› ‹†⇩S⇩M⇩C⇩.⇩R⇩e⇩l α›
rewrites "f : b ↦⇘op_smc ℭ'⇙ a ⟷ f : a ↦⇘ℭ'⇙ b" for ℭ' f a b
unfolding smc_op_simps by (auto simp: smcf_dag_Rel_is_iso_semifunctor)
have dag: "†⇩S⇩M⇩C⇩.⇩R⇩e⇩l α : op_smc (smc_Rel α) ↦↦⇩S⇩M⇩C⇘α⇙ smc_Rel α"
by (auto intro: smc_cs_intros)
from HomCod.is_epic_arrD(1)[OF assms] have T: "T : A ↦⇘smc_Rel α⇙ B".
from T have "†⇩S⇩M⇩C⇩.⇩R⇩e⇩l α⦇ArrMap⦈⦇T⦈ :
†⇩S⇩M⇩C⇩.⇩R⇩e⇩l α⦇ObjMap⦈⦇B⦈ ↦⇘smc_Rel α⇙ †⇩S⇩M⇩C⇩.⇩R⇩e⇩l α⦇ObjMap⦈⦇A⦈"
by (auto intro: smc_cs_intros)
with T show dag_T: "†⇩S⇩M⇩C⇩.⇩R⇩e⇩l α⦇ArrMap⦈⦇T⦈ : B ↦⇘smc_Rel α⇙ A"
unfolding smcf_dag_Rel_components(1)
by (metis HomCod.smc_is_arrD(2) HomCod.smc_is_arrD(3) vid_on_eq_atI)
fix f g a :: V
assume prems:
"f : a ↦⇘smc_Rel α⇙ B"
"g : a ↦⇘smc_Rel α⇙ B"
"†⇩S⇩M⇩C⇩.⇩R⇩e⇩l α⦇ArrMap⦈⦇T⦈ ∘⇩A⇘smc_Rel α⇙ f = †⇩S⇩M⇩C⇩.⇩R⇩e⇩l α⦇ArrMap⦈⦇T⦈ ∘⇩A⇘smc_Rel α⇙ g"
then have a: "a ∈⇩∘ smc_Rel α⦇Obj⦈" by auto
from prems(1) have "†⇩S⇩M⇩C⇩.⇩R⇩e⇩l α⦇ArrMap⦈⦇f⦈ :
†⇩S⇩M⇩C⇩.⇩R⇩e⇩l α⦇ObjMap⦈⦇B⦈ ↦⇘smc_Rel α⇙ †⇩S⇩M⇩C⇩.⇩R⇩e⇩l α⦇ObjMap⦈⦇a⦈"
by (auto intro: smc_cs_intros)
with prems(1) have dag_f: "†⇩S⇩M⇩C⇩.⇩R⇩e⇩l α⦇ArrMap⦈⦇f⦈ : B ↦⇘smc_Rel α⇙ a"
by (cs_concl cs_intro: smc_cs_intros cs_simp: smc_Rel_cs_simps)
from prems(2) have "†⇩S⇩M⇩C⇩.⇩R⇩e⇩l α⦇ArrMap⦈⦇g⦈ :
†⇩S⇩M⇩C⇩.⇩R⇩e⇩l α⦇ObjMap⦈⦇B⦈ ↦⇘smc_Rel α⇙ †⇩S⇩M⇩C⇩.⇩R⇩e⇩l α⦇ObjMap⦈⦇a⦈"
by (cs_concl cs_intro: smc_cs_intros cs_simp:)
with prems(2) have dag_g: "†⇩S⇩M⇩C⇩.⇩R⇩e⇩l α⦇ArrMap⦈⦇g⦈ : B ↦⇘smc_Rel α⇙ a"
by (cs_concl cs_intro: smc_cs_intros cs_simp: smc_Rel_cs_simps)
from T dag have
"†⇩S⇩M⇩C⇩.⇩R⇩e⇩l α⦇ArrMap⦈⦇†⇩S⇩M⇩C⇩.⇩R⇩e⇩l α⦇ArrMap⦈⦇T⦈⦈ =
(†⇩S⇩M⇩C⇩.⇩R⇩e⇩l α ⇩S⇩M⇩C⇩F∘ †⇩S⇩M⇩C⇩.⇩R⇩e⇩l α)⦇ArrMap⦈⦇T⦈"
by
(
cs_concl
cs_intro: smc_cs_intros
cs_simp: smc_Rel_cs_simps smc_cn_cs_simps smc_cs_simps
)
also from T have "… = T"
unfolding dghm_id_components smcf_cn_comp_smcf_dag_Rel_smcf_dag_Rel by auto
finally have dag_dag_T: "†⇩S⇩M⇩C⇩.⇩R⇩e⇩l α⦇ArrMap⦈⦇†⇩S⇩M⇩C⇩.⇩R⇩e⇩l α⦇ArrMap⦈⦇T⦈⦈ = T" by simp
have
"†⇩S⇩M⇩C⇩.⇩R⇩e⇩l α⦇ArrMap⦈⦇f⦈ ∘⇩A⇘smc_Rel α⇙ T = †⇩S⇩M⇩C⇩.⇩R⇩e⇩l α⦇ArrMap⦈⦇g⦈ ∘⇩A⇘smc_Rel α⇙ T"
by (metis dag_T dag_dag_T prems smcf_dag_Rel_ArrMap_smc_Rel_Comp)
from HomCod.is_epic_arrD(2)[OF assms dag_f dag_g this] prems ArrMap.v11_eq_iff
show "f = g"
by blast
qed
lemma (in 𝒵) smc_Rel_is_epic_arrI:
assumes "T : A ↦⇘smc_Rel α⇙ B"
and "⋀y z X. ⟦ y ⊆⇩∘ B; z ⊆⇩∘ B; T⦇ArrVal⦈ -`⇩∘ y = X; T⦇ArrVal⦈ -`⇩∘ z = X ⟧ ⟹
y = z"
shows "T : A ↦⇩e⇩p⇩i⇘smc_Rel α⇙ B"
proof-
interpret is_iso_semifunctor α ‹op_smc (smc_Rel α)› ‹smc_Rel α› ‹†⇩S⇩M⇩C⇩.⇩R⇩e⇩l α›
rewrites "f : b ↦⇘op_smc ℭ'⇙ a ⟷ f : a ↦⇘ℭ'⇙ b" for ℭ' f a b
unfolding smc_op_simps by (auto simp: smcf_dag_Rel_is_iso_semifunctor)
from assms have T: "arr_Rel α T" by (auto simp: smc_Rel_is_arrD(1))
have "†⇩S⇩M⇩C⇩.⇩R⇩e⇩l α⦇ArrMap⦈⦇T⦈ : B ↦⇩m⇩o⇩n⇘smc_Rel α⇙ A"
proof(rule smc_Rel_is_monic_arrI)
from assms(1) have "†⇩S⇩M⇩C⇩.⇩R⇩e⇩l α⦇ArrMap⦈⦇T⦈ :
†⇩S⇩M⇩C⇩.⇩R⇩e⇩l α⦇ObjMap⦈⦇B⦈ ↦⇘smc_Rel α⇙ †⇩S⇩M⇩C⇩.⇩R⇩e⇩l α⦇ObjMap⦈⦇A⦈"
by (cs_concl cs_intro: smc_cs_intros)
with assms(1) show "†⇩S⇩M⇩C⇩.⇩R⇩e⇩l α⦇ArrMap⦈⦇T⦈ : B ↦⇘smc_Rel α⇙ A"
by (cs_concl cs_intro: smc_cs_intros cs_simp: smc_Rel_cs_simps)
fix y z X
assume
"y ⊆⇩∘ B"
"z ⊆⇩∘ B"
"†⇩S⇩M⇩C⇩.⇩R⇩e⇩l α⦇ArrMap⦈⦇T⦈⦇ArrVal⦈ `⇩∘ y = X"
"†⇩S⇩M⇩C⇩.⇩R⇩e⇩l α⦇ArrMap⦈⦇T⦈⦇ArrVal⦈ `⇩∘ z = X"
then show "y = z"
unfolding
converse_Rel_components
smcf_dag_Rel_ArrMap_app[OF T]
app_invimage_def[symmetric]
by (rule assms(2))
qed
from smc_Rel_is_monic_arr_is_epic_arr[OF assms(1) this] show ?thesis by simp
qed
lemma (in 𝒵) smc_Rel_is_epic_arrD[dest]:
assumes "T : A ↦⇩e⇩p⇩i⇘smc_Rel α⇙ B"
and "y ⊆⇩∘ B"
and "z ⊆⇩∘ B"
and "T⦇ArrVal⦈ -`⇩∘ y = X"
and "T⦇ArrVal⦈ -`⇩∘ z = X"
shows "y = z"
proof-
interpret is_iso_semifunctor α ‹op_smc (smc_Rel α)› ‹smc_Rel α› ‹†⇩S⇩M⇩C⇩.⇩R⇩e⇩l α›
rewrites "f : b ↦⇘op_smc ℭ'⇙ a ⟷ f : a ↦⇘ℭ'⇙ b"
for ℭ' f a b
unfolding smc_op_simps by (auto simp: smcf_dag_Rel_is_iso_semifunctor)
have dag_T: "†⇩S⇩M⇩C⇩.⇩R⇩e⇩l α⦇ArrMap⦈⦇T⦈ : B ↦⇩m⇩o⇩n⇘smc_Rel α⇙ A"
by (rule smc_Rel_is_epic_arr_is_monic_arr[OF assms(1)])
from HomCod.is_epic_arrD(1)[OF assms(1)] have T: "T : A ↦⇘smc_Rel α⇙ B".
then have T: "arr_Rel α T" by (auto simp: smc_Rel_is_arrD(1))
from
assms(4,5)
smc_Rel_is_monic_arrD
[
OF dag_T assms(2,3),
unfolded
smc_dg_smc_Rel
smcf_dghm_smcf_dag_Rel
converse_Rel_components
smcf_dag_Rel_ArrMap_app[OF T]
]
show ?thesis
by (auto simp: app_invimage_def)
qed
lemma (in 𝒵) smc_Rel_is_epic_arr:
"T : A ↦⇩e⇩p⇩i⇘smc_Rel α⇙ B ⟷
T : A ↦⇘smc_Rel α⇙ B ∧
(
∀y z X.
y ⊆⇩∘ B ⟶
z ⊆⇩∘ B ⟶
T⦇ArrVal⦈ -`⇩∘ y = X ⟶
T⦇ArrVal⦈ -`⇩∘ z = X ⟶
y = z
)"
proof(intro iffI allI impI conjI)
show "T : A ↦⇩e⇩p⇩i⇘smc_Rel α⇙ B ⟹ T : A ↦⇘smc_Rel α⇙ B"
by (simp add: is_epic_arr_def is_monic_arr_def op_smc_is_arr)
qed (auto simp: smc_Rel_is_epic_arrI)
subsection‹Terminal object, initial object and null object›
text‹
An object in the semicategory ‹Rel› is terminal/initial/null if and only if
it is the empty set (see
nLab \cite{noauthor_nlab_nodate})\footnote{
\url{https://ncatlab.org/nlab/show/database+of+categories}
}.
›
lemma (in 𝒵) smc_Rel_obj_terminal: "obj_terminal (smc_Rel α) A ⟷ A = 0"
proof-
interpret semicategory α ‹smc_Rel α› by (rule semicategory_smc_Rel)
have "(∀A∈⇩∘Vset α. ∃!T. T : A ↦⇘smc_Rel α⇙ B) ⟷ B = 0" for B
proof(intro iffI allI ballI)
assume prems[rule_format]: "∀A∈⇩∘Vset α. ∃!T. T : A ↦⇘smc_Rel α⇙ B"
then obtain T where "T : 0 ↦⇘smc_Rel α⇙ B" by (meson vempty_is_zet)
then have [simp]: "B ∈⇩∘ Vset α" by (fastforce simp: smc_Rel_components(1))
show "B = 0"
proof(rule ccontr)
assume "B ≠ 0"
with trad_foundation obtain b where "b ∈⇩∘ B" by auto
let ?b0B = ‹[set {⟨0, b⟩}, set {0}, B]⇩∘›
let ?z0B = ‹[0, set {0}, B]⇩∘›
have "?b0B : set {0} ↦⇘smc_Rel α⇙ B"
proof(intro smc_Rel_is_arrI)
show b0B: "arr_Rel α ?b0B"
by (intro arr_Rel_vfsequenceI)
(force simp: ‹b ∈⇩∘ B› vsubset_vsingleton_leftI)+
qed (simp_all add: arr_Rel_components)
moreover have "?z0B : set {0} ↦⇘smc_Rel α⇙ B"
proof(intro smc_Rel_is_arrI)
show b0B: "arr_Rel α ?z0B"
by (intro arr_Rel_vfsequenceI)
(force simp: ‹b ∈⇩∘ B› vsubset_vsingleton_leftI)+
qed (simp_all add: arr_Rel_components)
moreover have "[set {⟨0, b⟩}, set {0}, B]⇩∘ ≠ [0, set {0}, B]⇩∘" by simp
ultimately show False
by (metis prems smc_is_arrE smc_Rel_components(1))
qed
next
fix A assume prems[simp]: "B = 0" "A ∈⇩∘ Vset α"
let ?zAz = ‹[0, A, 0]⇩∘›
have zAz: "arr_Rel α ?zAz"
by
(
simp add:
𝒵.arr_Rel_vfsequenceI
𝒵_axioms
smc_Rel_components(2)
vbrelation_vempty
)
show "∃!T. T : A ↦⇘smc_Rel α⇙ B"
proof(rule ex1I[of _ ‹?zAz›])
show "?zAz : A ↦⇘smc_Rel α⇙ B"
by (intro smc_Rel_is_arrI)
(
simp_all add:
zAz
smc_Rel_Dom_app[OF zAz]
smc_Rel_Cod_app[OF zAz]
arr_Rel_components
)
fix T assume "T : A ↦⇘smc_Rel α⇙ B"
then have T: "T : A ↦⇘smc_Rel α⇙ 0" by simp
then interpret T: arr_Rel α T by (fastforce simp: smc_Rel_components(2))
show "T = [0, A, 0]⇩∘"
proof
(
subst T.arr_Rel_def,
rule arr_Rel_eqI[of α],
unfold arr_Rel_components
)
show "arr_Rel α [T⦇ArrVal⦈, T⦇ArrDom⦈, T⦇ArrCod⦈]⇩∘"
by (fold T.arr_Rel_def) (simp add: T.arr_Rel_axioms)
from zAz show "arr_Rel α ?zAz"
by (simp add: arr_Rel_vfsequenceI vbrelationI)
from T have "T ∈⇩∘ smc_Rel α⦇Arr⦈" by (auto intro: smc_cs_intros)
with is_arrD(2,3)[OF T] show "T⦇ArrDom⦈ = A" "T⦇ArrCod⦈ = 0"
using T smc_Rel_is_arrD(2,3) by auto
with T.arr_Rel_ArrVal_vrange T.ArrVal.vbrelation_vintersection_vrange
show "T⦇ArrVal⦈ = []⇩∘"
by auto
qed
qed
qed
then show ?thesis
apply(intro iffI obj_terminalI)
subgoal by (metis smc_is_arrD(2) obj_terminalE)
subgoal by blast
subgoal by (metis smc_Rel_components(1))
done
qed
lemma (in 𝒵) smc_Rel_obj_initial: "obj_initial (smc_Rel α) A ⟷ A = 0"
proof-
interpret semicategory α ‹smc_Rel α› by (rule semicategory_smc_Rel)
have "(∀B∈⇩∘Vset α. ∃!T. T : A ↦⇘smc_Rel α⇙ B) ⟷ A = 0" for A
proof(intro iffI allI ballI)
assume prems[rule_format]: "∀B∈⇩∘Vset α. ∃!T. T : A ↦⇘smc_Rel α⇙ B"
then obtain T where TA0: "T : A ↦⇘smc_Rel α⇙ 0" by (meson vempty_is_zet)
then have [simp]: "A ∈⇩∘ Vset α" by (fastforce simp: smc_Rel_components(1))
show "A = 0"
proof(rule ccontr)
assume "A ≠ 0"
with trad_foundation obtain a where "a ∈⇩∘ A" by auto
have "[set {⟨a, 0⟩}, A, set {0}]⇩∘ : A ↦⇘smc_Rel α⇙ set {0}"
proof(intro smc_Rel_is_arrI)
show "arr_Rel α [set {⟨a, 0⟩}, A, set {0}]⇩∘"
by (intro arr_Rel_vfsequenceI)
(auto simp: ‹a ∈⇩∘ A› vsubset_vsingleton_leftI)
qed (simp_all add: arr_Rel_components)
moreover have "[0, A, set {0}]⇩∘ : A ↦⇘smc_Rel α⇙ set {0}"
proof(intro smc_Rel_is_arrI)
show "arr_Rel α [0, A, set {0}]⇩∘"
by (intro arr_Rel_vfsequenceI)
(auto simp: ‹a ∈⇩∘ A› vsubset_vsingleton_leftI)
qed (simp_all add: arr_Rel_components)
moreover have "[set {⟨a, 0⟩}, A, set {0}]⇩∘ ≠ [0, A, set {0}]⇩∘" by simp
ultimately show False
by (metis prems smc_is_arrE smc_Rel_components(1))
qed
next
fix B assume [simp]: "A = 0" "B ∈⇩∘ Vset α"
show "∃!T. T : A ↦⇘smc_Rel α⇙ B"
proof(rule ex1I[of _ ‹[0, 0, B]⇩∘›])
show "[0, 0, B]⇩∘ : A ↦⇘smc_Rel α⇙ B"
by (rule is_arrI)
(
simp_all add:
smc_Rel_cs_simps
smc_Rel_components(2)
vbrelation_vempty
arr_Rel_vfsequenceI
)
fix T assume "T : A ↦⇘smc_Rel α⇙ B"
then have T: "T : 0 ↦⇘smc_Rel α⇙ B" by simp
interpret T: arr_Rel α T
using T by (fastforce simp: smc_Rel_components(2))
show "T = [0, 0, B]⇩∘"
proof
(
subst T.arr_Rel_def,
rule arr_Rel_eqI[of α],
unfold arr_Rel_components
)
show "arr_Rel α [T⦇ArrVal⦈, T⦇ArrDom⦈, T⦇ArrCod⦈]⇩∘"
by (fold T.arr_Rel_def) (simp add: T.arr_Rel_axioms)
show "arr_Rel α [[]⇩∘, []⇩∘, B]⇩∘"
by (simp add: arr_Rel_vfsequenceI vbrelationI)
from T have "T ∈⇩∘ smc_Rel α⦇Arr⦈" by (auto intro: smc_cs_intros)
with T is_arrD(2,3)[OF T] show "T⦇ArrDom⦈ = 0" "T⦇ArrCod⦈ = B"
by (auto simp: smc_Rel_is_arrD(2,3))
with
T.arr_Rel_ArrVal_vrange
T.arr_Rel_ArrVal_vdomain
T.ArrVal.vbrelation_vintersection_vdomain
show "T⦇ArrVal⦈ = []⇩∘"
by auto
qed
qed
qed
then show ?thesis
apply(intro iffI obj_initialI, elim obj_initialE)
subgoal by (metis smc_Rel_components(1))
subgoal by (simp add: smc_Rel_components(1))
subgoal by (metis smc_Rel_components(1))
done
qed
lemma (in 𝒵) smc_Rel_obj_terminal_obj_initial:
"obj_initial (smc_Rel α) A ⟷ obj_terminal (smc_Rel α) A"
unfolding smc_Rel_obj_initial smc_Rel_obj_terminal by simp
lemma (in 𝒵) smc_Rel_obj_null: "obj_null (smc_Rel α) A ⟷ A = 0"
unfolding obj_null_def smc_Rel_obj_terminal smc_Rel_obj_initial by simp
subsection‹Zero arrow›
text‹
A zero arrow for ‹Rel› is any admissible ‹V›-arrow, such that its value
is the empty set. A reference for this result is not given, but the
result is not expected to be original.
›
lemma (in 𝒵) smc_Rel_is_zero_arr:
assumes "A ∈⇩∘ Vset α" and "B ∈⇩∘ Vset α"
shows "T : A ↦⇩0⇘smc_Rel α⇙ B ⟷ T = [0, A, B]⇩∘"
proof(rule HOL.ext iffI)
interpret Rel: semicategory α ‹smc_Rel α› by (rule semicategory_smc_Rel)
fix T A B assume "T : A ↦⇩0⇘smc_Rel α⇙ B"
then obtain R S
where T_def: "T = R ∘⇩A⇘smc_Rel α⇙ S"
and S: "S : A ↦⇘smc_Rel α⇙ 0"
and R: "R : 0 ↦⇘smc_Rel α⇙ B"
by (elim is_zero_arrE) (simp add: obj_null_def smc_Rel_obj_terminal)
interpret S: arr_Rel α S
rewrites [simp]: "S⦇ArrDom⦈ = A" and [simp]: "S⦇ArrCod⦈ = 0"
using S by (all‹elim Rel.smc_is_arrE›) (simp_all add: smc_Rel_components)
interpret R: arr_Rel α R
rewrites [simp]: "R⦇ArrDom⦈ = 0" and [simp]: "R⦇ArrCod⦈ = B"
using R by (all‹elim Rel.smc_is_arrE›) (simp_all add: smc_Rel_components)
have S_def: "S = [0, A, 0]⇩∘"
by
(
rule arr_Rel_eqI[of α],
unfold arr_Rel_components,
insert S.arr_Rel_ArrVal_vrange S.ArrVal.vbrelation_vintersection_vrange
)
(
auto simp:
S.arr_Rel_axioms
S.arr_Rel_ArrDom_in_Vset
arr_Rel_vfsequenceI
vbrelationI
)
show "T = [0, A, B]⇩∘"
unfolding T_def smc_Rel_Comp_app[OF R S]
by (rule arr_Rel_eqI[of α], unfold comp_Rel_components)
(
auto simp:
S_def
𝒵_axioms
R.arr_Rel_axioms
S.arr_Rel_axioms
arr_Rel_comp_Rel
arr_Rel_components
R.arr_Rel_ArrCod_in_Vset
S.arr_Rel_ArrDom_in_Vset
𝒵.arr_Rel_vfsequenceI
vbrelation_vempty
)
next
assume prems: "T = [0, A, B]⇩∘"
let ?S = ‹[0, A, 0]⇩∘› and ?R = ‹[0, 0, B]⇩∘›
have S: "arr_Rel α ?S" and R: "arr_Rel α ?R"
by (all‹intro arr_Rel_vfsequenceI›) (auto simp: assms)
have SA0: "?S : A ↦⇘smc_Rel α⇙ 0"
by (intro smc_Rel_is_arrI) (simp_all add: S arr_Rel_components)
moreover have R0B: "?R : 0 ↦⇘smc_Rel α⇙ B"
by (intro smc_Rel_is_arrI) (simp_all add: R arr_Rel_components)
moreover have "T = ?R ∘⇩A⇘smc_Rel α⇙ ?S"
unfolding smc_Rel_Comp_app[OF R0B SA0]
proof(rule arr_Rel_eqI, unfold comp_Rel_components arr_Rel_components prems)
show "arr_Rel α [0, A, B]⇩∘"
unfolding prems by (intro arr_Rel_vfsequenceI) (auto simp: assms)
qed (use R S in ‹auto simp: smc_Rel_cs_intros›)
ultimately show "T : A ↦⇩0⇘smc_Rel α⇙ B"
by (simp add: is_zero_arrI smc_Rel_obj_null)
qed
text‹\newpage›
end
Theory CZH_SMC_Par
section‹‹Par› as a semicategory›
theory CZH_SMC_Par
imports
CZH_DG_Par
CZH_SMC_Rel
CZH_SMC_Subsemicategory
begin
subsection‹Background›
text‹
The methodology chosen for the exposition
of ‹Par› as a semicategory is analogous to the
one used in the previous chapter for the exposition of ‹Par› as a digraph.
›
named_theorems smc_Par_cs_simps
named_theorems smc_Par_cs_intros
lemmas (in arr_Par) [smc_Par_cs_simps] =
dg_Rel_shared_cs_simps
lemmas [smc_Par_cs_simps] =
dg_Rel_shared_cs_simps
arr_Par.arr_Par_length
arr_Par_comp_Par_id_Par_left
arr_Par_comp_Par_id_Par_right
lemmas [smc_Par_cs_intros] =
dg_Rel_shared_cs_intros
arr_Par_comp_Par
subsection‹‹Par› as a semicategory›
subsubsection‹Definition and elementary properties›
definition smc_Par :: "V ⇒ V"
where "smc_Par α =
[
Vset α,
set {T. arr_Par α T},
(λT∈⇩∘set {T. arr_Par α T}. T⦇ArrDom⦈),
(λT∈⇩∘set {T. arr_Par α T}. T⦇ArrCod⦈),
(λST∈⇩∘composable_arrs (dg_Par α). ST⦇0⦈ ∘⇩R⇩e⇩l ST⦇1⇩ℕ⦈)
]⇩∘"
text‹Components.›
lemma smc_Par_components:
shows "smc_Par α⦇Obj⦈ = Vset α"
and "smc_Par α⦇Arr⦈ = set {T. arr_Par α T}"
and "smc_Par α⦇Dom⦈ = (λT∈⇩∘set {T. arr_Par α T}. T⦇ArrDom⦈)"
and "smc_Par α⦇Cod⦈ = (λT∈⇩∘set {T. arr_Par α T}. T⦇ArrCod⦈)"
and "smc_Par α⦇Comp⦈ = (λST∈⇩∘composable_arrs (dg_Par α). ST⦇0⦈ ∘⇩R⇩e⇩l ST⦇1⇩ℕ⦈)"
unfolding smc_Par_def dg_field_simps by (simp_all add: nat_omega_simps)
text‹Slicing.›
lemma smc_dg_smc_Par: "smc_dg (smc_Par α) = dg_Par α"
proof(rule vsv_eqI)
have dom_lhs: "𝒟⇩∘ (smc_dg (smc_Par α)) = 4⇩ℕ"
unfolding smc_dg_def by (simp add: nat_omega_simps)
have dom_rhs: "𝒟⇩∘ (dg_Par α) = 4⇩ℕ"
unfolding dg_Par_def by (simp add: nat_omega_simps)
show "𝒟⇩∘ (smc_dg (smc_Par α)) = 𝒟⇩∘ (dg_Par α)"
unfolding dom_lhs dom_rhs by simp
show "a ∈⇩∘ 𝒟⇩∘ (smc_dg (smc_Par α)) ⟹ smc_dg (smc_Par α)⦇a⦈ = dg_Par α⦇a⦈"
for a
by
(
unfold dom_lhs,
elim_in_numeral,
unfold smc_dg_def dg_field_simps smc_Par_def dg_Par_def
)
(auto simp: nat_omega_simps)
qed (auto simp: dg_Par_def smc_dg_def)
lemmas_with [folded smc_dg_smc_Par, unfolded slicing_simps]:
smc_Par_Obj_iff = dg_Par_Obj_iff
and smc_Par_Arr_iff[smc_Par_cs_simps] = dg_Par_Arr_iff
and smc_Par_Dom_vsv[smc_Par_cs_intros] = dg_Par_Dom_vsv
and smc_Par_Dom_vdomain[smc_Par_cs_simps] = dg_Par_Dom_vdomain
and smc_Par_Dom_vrange = dg_Par_Dom_vrange
and smc_Par_Dom_app[smc_Par_cs_simps] = dg_Par_Dom_app
and smc_Par_Cod_vsv[smc_Par_cs_intros] = dg_Par_Cod_vsv
and smc_Par_Cod_vdomain[smc_Par_cs_simps] = dg_Par_Cod_vdomain
and smc_Par_Cod_vrange = dg_Par_Cod_vrange
and smc_Par_Cod_app[smc_Par_cs_simps] = dg_Par_Cod_app
and smc_Par_is_arrI = dg_Par_is_arrI
and smc_Par_is_arrD = dg_Par_is_arrD
and smc_Par_is_arrE = dg_Par_is_arrE
lemmas [smc_cs_simps] = smc_Par_is_arrD(2,3)
lemmas [smc_Par_cs_intros] = smc_Par_is_arrI
lemmas_with (in 𝒵) [folded smc_dg_smc_Par, unfolded slicing_simps]:
smc_Par_Hom_vifunion_in_Vset = dg_Par_Hom_vifunion_in_Vset
and smc_Par_incl_Par_is_arr = dg_Par_incl_Par_is_arr
and smc_Par_incl_Par_is_arr'[smc_Par_cs_intros] = dg_Par_incl_Par_is_arr'
lemmas [smc_Par_cs_intros] = 𝒵.smc_Par_incl_Par_is_arr'
subsubsection‹Composable arrows›
lemma smc_Par_composable_arrs_dg_Par:
"composable_arrs (dg_Par α) = composable_arrs (smc_Par α)"
unfolding composable_arrs_def smc_dg_smc_Par[symmetric] slicing_simps by simp
lemma smc_Par_Comp:
"smc_Par α⦇Comp⦈ = (λST∈⇩∘composable_arrs (smc_Par α). ST⦇0⦈ ∘⇩R⇩e⇩l ST⦇1⇩ℕ⦈)"
unfolding smc_Par_components smc_Par_composable_arrs_dg_Par ..
subsubsection‹Composition›
lemma smc_Par_Comp_app[smc_Par_cs_simps]:
assumes "S : B ↦⇘smc_Par α⇙ C" and "T : A ↦⇘smc_Par α⇙ B"
shows "S ∘⇩A⇘smc_Par α⇙ T = S ∘⇩R⇩e⇩l T"
proof-
from assms have "[S, T]⇩∘ ∈⇩∘ composable_arrs (smc_Par α)"
by (auto simp: smc_cs_intros)
then show "S ∘⇩A⇘smc_Par α⇙ T = S ∘⇩R⇩e⇩l T"
unfolding smc_Par_Comp by (simp add: nat_omega_simps)
qed
lemma smc_Par_Comp_vdomain: "𝒟⇩∘ (smc_Par α⦇Comp⦈) = composable_arrs (smc_Par α)"
unfolding smc_Par_Comp by simp
lemma (in 𝒵) smc_Par_Comp_vrange: "ℛ⇩∘ (smc_Par α⦇Comp⦈) ⊆⇩∘ set {T. arr_Par α T}"
proof(rule vsubsetI)
interpret digraph α ‹smc_dg (smc_Par α)›
unfolding smc_dg_smc_Par by (simp add: digraph_dg_Par)
fix R assume "R ∈⇩∘ ℛ⇩∘ (smc_Par α⦇Comp⦈)"
then obtain ST
where R_def: "R = smc_Par α⦇Comp⦈⦇ST⦈"
and "ST ∈⇩∘ 𝒟⇩∘ (smc_Par α⦇Comp⦈)"
unfolding smc_Par_components by (blast dest: rel_VLambda.vrange_atD)
then obtain S T A B C
where "ST = [S, T]⇩∘"
and S: "S : B ↦⇘smc_Par α⇙ C"
and T: "T : A ↦⇘smc_Par α⇙ B"
by (auto simp: smc_Par_Comp_vdomain)
with R_def have R_def': "R = S ∘⇩A⇘smc_Par α⇙ T" by simp
note S_D = dg_is_arrD(1)[unfolded slicing_simps, OF S]
and T_D = dg_is_arrD(1)[unfolded slicing_simps, OF T]
from S_D T_D have "arr_Par α S" "arr_Par α T"
by (simp_all add: smc_Par_components)
from this show "R ∈⇩∘ set {T. arr_Par α T}"
unfolding R_def' smc_Par_Comp_app[OF S T] by (auto simp: arr_Par_comp_Par)
qed
subsubsection‹‹Par› is a semicategory›
lemma (in 𝒵) semicategory_smc_Par: "semicategory α (smc_Par α)"
proof(intro semicategoryI, unfold smc_dg_smc_Par)
show "vfsequence (smc_Par α)" unfolding smc_Par_def by simp
show "vcard (smc_Par α) = 5⇩ℕ"
unfolding smc_Par_def by (simp add: nat_omega_simps)
show "(GF ∈⇩∘ 𝒟⇩∘ (smc_Par α⦇Comp⦈)) ⟷
(∃G F B C A. GF = [G, F]⇩∘ ∧ G : B ↦⇘smc_Par α⇙ C ∧ F : A ↦⇘smc_Par α⇙ B)"
for GF
unfolding smc_Par_Comp_vdomain by (auto intro: composable_arrsI)
show [intro]: "G ∘⇩A⇘smc_Par α⇙ F : A ↦⇘smc_Par α⇙ C"
if "G : B ↦⇘smc_Par α⇙ C" and "F : A ↦⇘smc_Par α⇙ B" for G B C F A
proof-
from that have "arr_Par α G" "arr_Par α F" by (auto elim: smc_Par_is_arrE)
with that show ?thesis
by
(
cs_concl
cs_simp: smc_cs_simps smc_Par_cs_simps
cs_intro: smc_Par_cs_intros
)
qed
show "H ∘⇩A⇘smc_Par α⇙ G ∘⇩A⇘smc_Par α⇙ F = H ∘⇩A⇘smc_Par α⇙ (G ∘⇩A⇘smc_Par α⇙ F)"
if "H : C ↦⇘smc_Par α⇙ D"
and "G : B ↦⇘smc_Par α⇙ C"
and "F : A ↦⇘smc_Par α⇙ B"
for H C D G B F A
proof-
from that have "arr_Par α H" "arr_Par α G" "arr_Par α F"
by (auto simp: smc_Par_is_arrD)
with that show ?thesis
by
(
cs_concl
cs_simp: smc_cs_simps smc_Par_cs_simps
cs_intro: smc_Par_cs_intros
)
qed
qed (auto simp: digraph_dg_Par smc_Par_components)
subsubsection‹‹Par› is a wide subsemicategory of ‹Rel››
lemma (in 𝒵) wide_subsemicategory_smc_Par_smc_Rel:
"smc_Par α ⊆⇩S⇩M⇩C⇩.⇩w⇩i⇩d⇩e⇘α⇙ smc_Rel α"
proof-
interpret Rel: semicategory α ‹smc_Rel α› by (rule semicategory_smc_Rel)
interpret Par: semicategory α ‹smc_Par α› by (rule semicategory_smc_Par)
show ?thesis
proof
(
intro wide_subsemicategoryI subsemicategoryI,
unfold smc_dg_smc_Par smc_dg_smc_Rel
)
from wide_subdigraph_dg_Par_dg_Rel show wsd:
"dg_Par α ⊆⇩D⇩G⇘α⇙ dg_Rel α" "dg_Par α ⊆⇩D⇩G⇩.⇩w⇩i⇩d⇩e⇘α⇙ dg_Rel α"
by auto
interpret wide_subdigraph α ‹dg_Par α› ‹dg_Rel α› by (rule wsd(2))
show "G ∘⇩A⇘smc_Par α⇙ F = G ∘⇩A⇘smc_Rel α⇙ F"
if "G : B ↦⇘smc_Par α⇙ C" and "F : A ↦⇘smc_Par α⇙ B" for G B C F A
proof-
from that have "G : B ↦⇘dg_Par α⇙ C" and "F : A ↦⇘dg_Par α⇙ B"
by (cs_concl cs_simp: smc_dg_smc_Par[symmetric] cs_intro: slicing_intros)+
then have "G : B ↦⇘dg_Rel α⇙ C" and "F : A ↦⇘dg_Rel α⇙ B"
by (cs_concl cs_intro: dg_sub_fw_cs_intros)+
then have "G : B ↦⇘smc_Rel α⇙ C" and "F : A ↦⇘smc_Rel α⇙ B"
unfolding smc_dg_smc_Rel[symmetric] slicing_simps by simp_all
from that this show "G ∘⇩A⇘smc_Par α⇙ F = G ∘⇩A⇘smc_Rel α⇙ F"
by (cs_concl cs_simp: smc_Par_cs_simps smc_Rel_cs_simps)
qed
qed (auto simp: smc_cs_intros)
qed
subsection‹Monic arrow and epic arrow›
lemma (in 𝒵) smc_Par_is_monic_arrI[intro]:
assumes "T : A ↦⇘smc_Par α⇙ B" and "v11 (T⦇ArrVal⦈)" and "𝒟⇩∘ (T⦇ArrVal⦈) = A"
shows "T : A ↦⇩m⇩o⇩n⇘smc_Par α⇙ B"
proof(intro is_monic_arrI)
interpret Par_Rel: wide_subsemicategory α ‹smc_Par α› ‹smc_Rel α›
by (rule wide_subsemicategory_smc_Par_smc_Rel)
interpret v11: v11 ‹T⦇ArrVal⦈› by (rule assms(2))
show T: "T : A ↦⇘smc_Par α⇙ B" by (rule assms(1))
fix S R A'
assume S: "S : A' ↦⇘smc_Par α⇙ A"
and R: "R : A' ↦⇘smc_Par α⇙ A"
and TS_TR: "T ∘⇩A⇘smc_Par α⇙ S = T ∘⇩A⇘smc_Par α⇙ R"
from assms(3) T Par_Rel.subsemicategory_axioms have "T : A ↦⇩m⇩o⇩n⇘smc_Rel α⇙ B"
by (intro smc_Rel_is_monic_arrI)
(auto dest: v11.v11_vimage_vpsubset_neq elim!: smc_sub_fw_cs_intros)
moreover from S Par_Rel.subsemicategory_axioms have "S : A' ↦⇘smc_Rel α⇙ A"
by (cs_concl cs_intro: smc_sub_fw_cs_intros)
moreover from R Par_Rel.subsemicategory_axioms have "R : A' ↦⇘smc_Rel α⇙ A"
by (cs_concl cs_intro: smc_sub_fw_cs_intros)
moreover from T S R TS_TR Par_Rel.subsemicategory_axioms have
"T ∘⇩A⇘smc_Rel α⇙ S = T ∘⇩A⇘smc_Rel α⇙ R"
by (auto simp: smc_sub_bw_cs_simps)
ultimately show "S = R" by (rule is_monic_arrD(2))
qed
lemma (in 𝒵) smc_Par_is_monic_arrD:
assumes "T : A ↦⇩m⇩o⇩n⇘smc_Par α⇙ B"
shows "T : A ↦⇘smc_Par α⇙ B" and "v11 (T⦇ArrVal⦈)" and "𝒟⇩∘ (T⦇ArrVal⦈) = A"
proof-
from assms show T: "T : A ↦⇘smc_Par α⇙ B" by auto
interpret T: arr_Par α T
rewrites [simp]: "T⦇ArrDom⦈ = A" and [simp]: "T⦇ArrCod⦈ = B"
using T by (auto dest: smc_Par_is_arrD)
show "v11 (T⦇ArrVal⦈)"
proof(intro v11I)
show "vsv ((T⦇ArrVal⦈)¯⇩∘)"
proof(intro vsvI)
fix a b c assume "⟨a, b⟩ ∈⇩∘ (T⦇ArrVal⦈)¯⇩∘" and "⟨a, c⟩ ∈⇩∘ (T⦇ArrVal⦈)¯⇩∘"
then have bar: "⟨b, a⟩ ∈⇩∘ T⦇ArrVal⦈" and car: "⟨c, a⟩ ∈⇩∘ T⦇ArrVal⦈" by auto
with T.arr_Rel_ArrVal_vdomain have [intro]: "b ∈⇩∘ A" "c ∈⇩∘ A" by auto
define R where "R = [set {⟨0, b⟩}, set {0}, A]⇩∘"
define S where "S = [set {⟨0, c⟩}, set {0}, A]⇩∘"
have R_components:
"R⦇ArrVal⦈ = set {⟨0, b⟩}" "R⦇ArrDom⦈ = set {0}" "R⦇ArrCod⦈ = A"
unfolding R_def by (simp_all add: arr_Rel_components)
have S_components:
"S⦇ArrVal⦈ = set {⟨0, c⟩}" "S⦇ArrDom⦈ = set {0}" "S⦇ArrCod⦈ = A"
unfolding S_def by (simp_all add: arr_Rel_components)
have R: "R : set {0} ↦⇘smc_Par α⇙ A"
proof(rule smc_Par_is_arrI)
show "arr_Par α R"
unfolding R_def
by (rule arr_Par_vfsequenceI) (auto simp: T.arr_Rel_ArrDom_in_Vset)
qed (simp_all add: R_components)
have S: "S : set {0} ↦⇘smc_Par α⇙ A"
proof(rule smc_Par_is_arrI)
show "arr_Par α S"
unfolding S_def
by (rule arr_Par_vfsequenceI) (auto simp: T.arr_Rel_ArrDom_in_Vset)
qed (simp_all add: S_components)
have "T ∘⇩A⇘smc_Par α⇙ R = [set {⟨0, a⟩}, set {0}, B]⇩∘"
unfolding smc_Par_Comp_app[OF T R]
proof
(
rule arr_Par_eqI[of α],
unfold comp_Rel_components arr_Rel_components R_components
)
from R T show "arr_Par α (T ∘⇩R⇩e⇩l R)"
by (intro arr_Par_comp_Par) (auto elim!: smc_Par_is_arrE)
show "arr_Par α [set {⟨0, a⟩}, set {0}, B]⇩∘"
proof(rule arr_Par_vfsequenceI)
from T.arr_Rel_ArrVal_vrange bar show "ℛ⇩∘ (set {⟨0, a⟩}) ⊆⇩∘ B" by auto
qed (auto simp: T.arr_Rel_ArrCod_in_Vset Axiom_of_Powers)
show "T⦇ArrVal⦈ ∘⇩∘ set {⟨0, b⟩} = set {⟨0, a⟩}"
proof(rule vsv_eqI, unfold vdomain_vsingleton)
from bar show "𝒟⇩∘ (T⦇ArrVal⦈ ∘⇩∘ set {⟨0, b⟩}) = set {0}" by auto
with bar show
"a' ∈⇩∘ 𝒟⇩∘ (T⦇ArrVal⦈ ∘⇩∘ set {⟨0, b⟩}) ⟹
(T⦇ArrVal⦈ ∘⇩∘ set {⟨0, b⟩})⦇a'⦈ = set {⟨0, a⟩}⦇a'⦈"
for a'
by auto
qed (auto intro: vsv_vcomp)
qed simp_all
moreover have "T ∘⇩A⇘smc_Par α⇙ S = [set {⟨0, a⟩}, set {0}, B]⇩∘"
unfolding smc_Par_Comp_app[OF T S]
proof
(
rule arr_Par_eqI[of α],
unfold comp_Rel_components arr_Rel_components S_components
)
from T S show "arr_Par α (T ∘⇩R⇩e⇩l S)"
by (intro arr_Par_comp_Par) (auto elim!: smc_Par_is_arrE)
show "arr_Par α [set {⟨0, a⟩}, set {0}, B]⇩∘"
proof(rule arr_Par_vfsequenceI)
from T.arr_Rel_ArrVal_vrange bar show "ℛ⇩∘ (set {⟨0, a⟩}) ⊆⇩∘ B" by auto
qed (auto simp: T.arr_Rel_ArrCod_in_Vset Axiom_of_Powers)
show "T⦇ArrVal⦈ ∘⇩∘ set {⟨0, c⟩} = set {⟨0, a⟩}"
proof(rule vsv_eqI, unfold vdomain_vsingleton)
from car show "𝒟⇩∘ (T⦇ArrVal⦈ ∘⇩∘ set {⟨0, c⟩}) = set {0}" by auto
with car show "a' ∈⇩∘ 𝒟⇩∘ (T⦇ArrVal⦈ ∘⇩∘ set {⟨0, c⟩}) ⟹
(T⦇ArrVal⦈ ∘⇩∘ set {⟨0, c⟩})⦇a'⦈ = set {⟨0, a⟩}⦇a'⦈"
for a'
by auto
qed (auto intro: vsv_vcomp)
qed simp_all
ultimately have "T ∘⇩A⇘smc_Par α⇙ R = T ∘⇩A⇘smc_Par α⇙ S" by simp
from assms R S this have "R = S" by blast
with R_components(1) S_components(1) show "b = c" by simp
qed auto
qed auto
show "𝒟⇩∘ (T⦇ArrVal⦈) = A"
proof(intro vsubset_antisym vsubsetI)
from T.arr_Rel_ArrVal_vdomain show "x ∈⇩∘ 𝒟⇩∘ (T⦇ArrVal⦈) ⟹ x ∈⇩∘ A" for x
by auto
fix a assume [simp]: "a ∈⇩∘ A" show "a ∈⇩∘ 𝒟⇩∘ (T⦇ArrVal⦈)"
proof(rule ccontr)
assume a: "a ∉⇩∘ 𝒟⇩∘ (T⦇ArrVal⦈)"
define R where "R = [set {⟨0, a⟩}, set {0, 1}, A]⇩∘"
define S where "S = [set {⟨1, a⟩}, set {0, 1}, A]⇩∘"
have R: "R : set {0, 1} ↦⇘smc_Par α⇙ A"
proof(rule smc_Par_is_arrI)
show "arr_Par α R"
unfolding R_def
proof(rule arr_Par_vfsequenceI)
from Axiom_of_Infinity vone_in_omega show "set {0, 1} ∈⇩∘ Vset α"
by blast
qed (auto simp: T.arr_Rel_ArrDom_in_Vset)
qed (auto simp: R_def arr_Rel_components)
have S: "S : set {0, 1} ↦⇘smc_Par α⇙ A"
proof(rule smc_Par_is_arrI)
show "arr_Par α S"
unfolding S_def
proof(rule arr_Par_vfsequenceI)
from Axiom_of_Infinity vone_in_omega show "set {0, 1} ∈⇩∘ Vset α"
by blast
qed (auto simp: T.arr_Rel_ArrDom_in_Vset)
qed (auto simp: S_def arr_Rel_components)
with a have "T⦇ArrVal⦈ ∘⇩∘ R⦇ArrVal⦈ = 0"
unfolding R_def arr_Rel_components
by (intro vsubset_antisym vsubsetI) auto
moreover with a have "T⦇ArrVal⦈ ∘⇩∘ S⦇ArrVal⦈ = 0"
unfolding S_def arr_Rel_components
by (intro vsubset_antisym vsubsetI) auto
ultimately have "T ∘⇩A⇘smc_Par α⇙ R = T ∘⇩A⇘smc_Par α⇙ S"
using R T S
by
(
intro arr_Par_eqI[of α ‹T ∘⇩A⇘smc_Par α⇙ R› ‹T ∘⇩A⇘smc_Par α⇙ S›];
elim smc_Par_is_arrE
)
(
auto simp:
dg_Par_cs_intros
smc_Par_Comp_app[OF T R]
smc_Par_Comp_app[OF T S]
comp_Rel_components
)
from R S this assms have "R = S" by blast
then show False unfolding R_def S_def by simp
qed
qed
qed
lemma (in 𝒵) smc_Par_is_monic_arr:
"T : A ↦⇩m⇩o⇩n⇘smc_Par α⇙ B ⟷
T : A ↦⇘smc_Par α⇙ B ∧ v11 (T⦇ArrVal⦈) ∧ 𝒟⇩∘ (T⦇ArrVal⦈) = A"
by (intro iffI) (auto simp: smc_Par_is_monic_arrD smc_Par_is_monic_arrI)
context 𝒵
begin
context
begin
private lemma smc_Par_is_epic_arr_vsubset:
assumes "T : A ↦⇘smc_Par α⇙ B"
and "ℛ⇩∘ (T⦇ArrVal⦈) = B"
and "R : B ↦⇘smc_Par α⇙ C"
and "S : B ↦⇘smc_Par α⇙ C"
and "R ∘⇩A⇘smc_Par α⇙ T = S ∘⇩A⇘smc_Par α⇙ T"
shows "R⦇ArrVal⦈ ⊆⇩∘ S⦇ArrVal⦈"
proof
interpret T: arr_Par α T
rewrites [simp]: "T⦇ArrDom⦈ = A" and [simp]: "T⦇ArrCod⦈ = B"
using assms smc_Par_is_arrD by auto
interpret R: arr_Par α R
rewrites [simp]: "R⦇ArrDom⦈ = B" and [simp]: "R⦇ArrCod⦈ = C"
using assms smc_Par_is_arrD by auto
from assms(5) have "(R ∘⇩A⇘smc_Par α⇙ T)⦇ArrVal⦈ = (S ∘⇩A⇘smc_Par α⇙ T)⦇ArrVal⦈"
by simp
then have eq: "R⦇ArrVal⦈ ∘⇩∘ T⦇ArrVal⦈ = S⦇ArrVal⦈ ∘⇩∘ T⦇ArrVal⦈"
unfolding
smc_Par_Comp_app[OF assms(3,1)]
smc_Par_Comp_app[OF assms(4,1)]
comp_Rel_components
by simp
fix bc assume prems: "bc ∈⇩∘ R⦇ArrVal⦈"
moreover with R.ArrVal.vbrelation obtain b c where bc_def: "bc = ⟨b, c⟩" by auto
ultimately have [simp]: "b ∈⇩∘ B" and "c ∈⇩∘ C"
using R.arr_Rel_ArrVal_vdomain R.arr_Rel_ArrVal_vrange by auto
note [intro] = prems[unfolded bc_def]
have "b ∈⇩∘ ℛ⇩∘ (T⦇ArrVal⦈)" by (simp add: assms(2))
then obtain a where ab: "⟨a, b⟩ ∈⇩∘ T⦇ArrVal⦈" by auto
then have "⟨a, c⟩ ∈⇩∘ S⦇ArrVal⦈ ∘⇩∘ T⦇ArrVal⦈" unfolding eq[symmetric] by auto
then obtain b' where ab': "⟨b', c⟩ ∈⇩∘ S⦇ArrVal⦈" and "⟨a, b'⟩ ∈⇩∘ T⦇ArrVal⦈"
by clarsimp
with ab ab' T.vsv T.ArrVal.vsv show "bc ∈⇩∘ S⦇ArrVal⦈" unfolding bc_def by blast
qed
lemma smc_Par_is_epic_arrI:
assumes "T : A ↦⇘smc_Par α⇙ B" and "ℛ⇩∘ (T⦇ArrVal⦈) = B"
shows "T : A ↦⇩e⇩p⇩i⇘smc_Par α⇙ B"
unfolding is_epic_arr_def
proof
(
intro is_monic_arrI[
of ‹op_smc (smc_Par α)›, unfolded smc_op_simps, OF assms(1)
]
)
interpret semicategory α ‹smc_Par α› by (rule semicategory_smc_Par)
fix R S a
assume prems:
"R : B ↦⇘smc_Par α⇙ a"
"S : B ↦⇘smc_Par α⇙ a"
"T ∘⇩A⇘op_smc (smc_Par α)⇙ R = T ∘⇩A⇘op_smc (smc_Par α)⇙ S"
from prems(3) have RT_ST: "R ∘⇩A⇘smc_Par α⇙ T = S ∘⇩A⇘smc_Par α⇙ T"
unfolding
op_smc_Comp[OF prems(1) assms(1)]
op_smc_Comp[OF prems(2) assms(1)]
by simp
from smc_Par_is_epic_arr_vsubset[OF assms(1,2) prems(1,2) this]
have RS: "R⦇ArrVal⦈ ⊆⇩∘ S⦇ArrVal⦈".
from smc_Par_is_epic_arr_vsubset[OF assms(1,2) prems(2,1) RT_ST[symmetric]]
have SR: "S⦇ArrVal⦈ ⊆⇩∘ R⦇ArrVal⦈".
from prems show "R = S"
by (intro arr_Par_eqI[of α R S])
(auto simp: RS SR vsubset_antisym elim!: smc_Par_is_arrE)
qed
lemma smc_Par_is_epic_arrD:
assumes "T : A ↦⇩e⇩p⇩i⇘smc_Par α⇙ B"
shows "T : A ↦⇘smc_Par α⇙ B" and "ℛ⇩∘ (T⦇ArrVal⦈) = B"
proof-
interpret semicategory α ‹smc_Par α› by (rule semicategory_smc_Par)
from assms show T: "T : A ↦⇘smc_Par α⇙ B"
unfolding is_epic_arr_def by (auto simp: op_smc_is_arr)
interpret T: arr_Par α T
rewrites [simp]: "T⦇ArrDom⦈ = A" and [simp]: "T⦇ArrCod⦈ = B"
using T by (auto elim: smc_Par_is_arrE)
show "ℛ⇩∘ (T⦇ArrVal⦈) = B"
proof(intro vsubset_antisym vsubsetI)
from T.arr_Rel_ArrVal_vrange show "y ∈⇩∘ ℛ⇩∘ (T⦇ArrVal⦈) ⟹ y ∈⇩∘ B" for y
by auto
fix b assume [intro]: "b ∈⇩∘ B" show "b ∈⇩∘ ℛ⇩∘ (T⦇ArrVal⦈)"
proof(rule ccontr)
assume prems: "b ∉⇩∘ ℛ⇩∘ (T⦇ArrVal⦈)"
define R where "R = [set {⟨b, 0⟩}, B, set {0, 1}]⇩∘"
define S where "S = [set {⟨b, 1⟩}, B, set {0, 1}]⇩∘"
have R: "R : B ↦⇘smc_Par α⇙ set {0, 1}"
unfolding R_def
proof(intro smc_Par_is_arrI arr_Par_vfsequenceI, unfold arr_Rel_components)
from Axiom_of_Infinity vone_in_omega show "set {0, 1} ∈⇩∘ Vset α"
by blast
qed (auto simp: T.arr_Rel_ArrCod_in_Vset)
have S: "S : B ↦⇘smc_Par α⇙ set {0, 1}"
unfolding S_def
proof(intro smc_Par_is_arrI arr_Par_vfsequenceI, unfold arr_Rel_components)
from Axiom_of_Infinity vone_in_omega show "set {0, 1} ∈⇩∘ Vset α"
by blast
qed (auto simp: T.arr_Rel_ArrCod_in_Vset)
from prems have "R⦇ArrVal⦈ ∘⇩∘ T⦇ArrVal⦈ = 0"
unfolding R_def arr_Rel_components
by (auto intro!: vsubset_antisym vsubsetI)
moreover from prems have "S⦇ArrVal⦈ ∘⇩∘ T⦇ArrVal⦈ = 0"
unfolding S_def arr_Rel_components
by (auto intro!: vsubset_antisym vsubsetI)
ultimately have "R ∘⇩A⇘smc_Par α⇙ T = S ∘⇩A⇘smc_Par α⇙ T"
unfolding smc_Par_Comp_app[OF R T] smc_Par_Comp_app[OF S T]
by (simp add: R_def S_def arr_Rel_components comp_Rel_def)
from is_epic_arrD(2)[OF assms R S this] show False
unfolding R_def S_def by simp
qed
qed
qed
end
end
lemma (in 𝒵) smc_Par_is_epic_arr:
"T : A ↦⇩e⇩p⇩i⇘smc_Par α⇙ B ⟷ T : A ↦⇘smc_Par α⇙ B ∧ ℛ⇩∘ (T⦇ArrVal⦈) = B"
by (intro iffI) (simp_all add: smc_Par_is_epic_arrD smc_Par_is_epic_arrI)
subsection‹Terminal object, initial object and null object›
lemma (in 𝒵) smc_Par_obj_terminal: "obj_terminal (smc_Par α) A ⟷ A = 0"
proof-
interpret semicategory α ‹smc_Par α› by (rule semicategory_smc_Par)
have "(∀A∈⇩∘Vset α. ∃!T. T : A ↦⇘smc_Par α⇙ B) ⟷ B = 0" for B
proof(intro iffI allI ballI)
assume prems[rule_format]: "∀A∈⇩∘Vset α. ∃!T. T : A ↦⇘smc_Par α⇙ B"
then obtain T where "T : 0 ↦⇘smc_Par α⇙ B" by (meson vempty_is_zet)
then have [simp]: "B ∈⇩∘ Vset α" by (fastforce simp: smc_Par_components(1))
show "B = 0"
proof(rule ccontr)
assume "B ≠ 0"
then obtain b where "b ∈⇩∘ B" using trad_foundation by auto
have "[set {⟨0, b⟩}, set {0}, B]⇩∘ : set {0} ↦⇘smc_Par α⇙ B"
by (intro smc_Par_is_arrI arr_Par_vfsequenceI, unfold arr_Rel_components)
(auto simp: ‹b ∈⇩∘ B› vsubset_vsingleton_leftI)
moreover have "[0, set {0}, B]⇩∘ : set {0} ↦⇘smc_Par α⇙ B"
by (intro smc_Par_is_arrI arr_Par_vfsequenceI, unfold arr_Rel_components)
(auto simp: ‹b ∈⇩∘ B› vsubset_vsingleton_leftI)
moreover have "[set {⟨0, b⟩}, set {0}, B]⇩∘ ≠ [0, set {0}, B]⇩∘" by simp
ultimately show False
by (metis prems smc_is_arrE smc_Par_components(1))
qed
next
fix A assume [simp]: "B = 0" "A ∈⇩∘ Vset α"
show "∃!T. T : A ↦⇘smc_Par α⇙ B"
proof(intro ex1I [of _ ‹[0, A, 0]⇩∘›])
show zAz: "[0, A, 0]⇩∘ : A ↦⇘smc_Par α⇙ B"
by
(
intro smc_Par_is_arrI arr_Par_vfsequenceI,
unfold arr_Rel_components
)
simp_all
show "T = [0, A, 0]⇩∘" if "T : A ↦⇘smc_Par α⇙ B" for T
proof(rule arr_Par_eqI[of α], unfold arr_Rel_components)
interpret arr_Par α T using that by (simp add: smc_Par_is_arrD(1))
from zAz show "arr_Par α [0, A, 0]⇩∘" by (auto elim: smc_Par_is_arrE)
from arr_Par_axioms that show "T⦇ArrVal⦈ = 0"
by (clarsimp simp: vsv.vsv_vrange_vempty smc_Par_is_arrD(3))
qed (use that in ‹auto dest: smc_Par_is_arrD›)
qed
qed
then show ?thesis
apply(intro iffI obj_terminalI)
subgoal by (metis smc_is_arrD(2) obj_terminalE)
subgoal by blast
subgoal by (metis smc_Par_components(1))
done
qed
lemma (in 𝒵) smc_Par_obj_initial: "obj_initial (smc_Par α) A ⟷ A = 0"
proof-
interpret Par: semicategory α ‹smc_Par α› by (rule semicategory_smc_Par)
have "(∀B∈⇩∘Vset α. ∃!T. T : A ↦⇘smc_Par α⇙ B) ⟷ (A = 0)" for A
proof(intro iffI allI ballI)
assume prems[rule_format]: "∀B∈⇩∘Vset α. ∃!T. T : A ↦⇘smc_Par α⇙ B"
then obtain T where "T : A ↦⇘smc_Par α⇙ 0"
by (meson vempty_is_zet)
then have [simp]: "A ∈⇩∘ Vset α" by (fastforce simp: smc_Par_components(1))
show "A = 0"
proof(rule ccontr)
assume "A ≠ 0"
then obtain a where "a ∈⇩∘ A" using trad_foundation by auto
have "[set {⟨a, 0⟩}, A, set {0}]⇩∘ : A ↦⇘smc_Par α⇙ set {0}"
by (intro smc_Par_is_arrI arr_Par_vfsequenceI, unfold arr_Rel_components)
(auto simp: ‹a ∈⇩∘ A› vsubset_vsingleton_leftI)
moreover have "[0, A, set {0}]⇩∘ : A ↦⇘smc_Par α⇙ set {0}"
by (intro smc_Par_is_arrI arr_Par_vfsequenceI, unfold arr_Rel_components)
(auto simp: ‹a ∈⇩∘ A› vsubset_vsingleton_leftI)
moreover have "[set {⟨a, 0⟩}, A, set {0}]⇩∘ ≠ [0, A, set {0}]⇩∘" by simp
ultimately show False
by (metis prems Par.smc_is_arrE smc_Par_components(1))
qed
next
fix B assume prems[simp]: "A = 0" "B ∈⇩∘ Vset α"
show "∃!T. T : A ↦⇘smc_Par α⇙ B"
proof(intro ex1I[of _ ‹[0, 0, B]⇩∘›])
show zzB: "[0, 0, B]⇩∘ : A ↦⇘smc_Par α⇙ B"
by
(
intro smc_Par_is_arrI arr_Par_vfsequenceI,
unfold arr_Rel_components
)
simp_all
show "T = [0, 0, B]⇩∘" if "T : A ↦⇘smc_Par α⇙ B" for T
proof(rule arr_Par_eqI[of α], unfold arr_Rel_components)
interpret arr_Par α T using that by (simp add: smc_Par_is_arrD(1))
show "arr_Par α T" by (rule arr_Par_axioms)
from zzB show "arr_Par α [0, 0, B]⇩∘" by (auto elim: smc_Par_is_arrE)
from arr_Par_axioms that show "T⦇ArrVal⦈ = 0"
by (elim smc_Par_is_arrE arr_ParE)
(
auto
intro: ArrVal.vsv_vrange_vempty
simp: ArrVal.vdomain_vrange_is_vempty
)
qed (use that in ‹auto dest: smc_Par_is_arrD›)
qed
qed
then show ?thesis
unfolding obj_initial_def
apply(intro iffI obj_terminalI, elim obj_terminalE, unfold smc_op_simps)
subgoal by (metis smc_Par_components(1))
subgoal by (simp add: smc_Par_components(1))
subgoal by (metis smc_Par_components(1))
done
qed
lemma (in 𝒵) smc_Par_obj_terminal_obj_initial:
"obj_initial (smc_Par α) A ⟷ obj_terminal (smc_Par α) A"
unfolding smc_Par_obj_initial smc_Par_obj_terminal by simp
lemma (in 𝒵) smc_Par_obj_null: "obj_null (smc_Par α) A ⟷ A = 0"
unfolding obj_null_def smc_Par_obj_terminal smc_Par_obj_initial by simp
subsection‹Zero arrow›
lemma (in 𝒵) smc_Par_is_zero_arr:
assumes "A ∈⇩∘ Vset α" and "B ∈⇩∘ Vset α"
shows "T : A ↦⇩0⇘smc_Par α⇙ B ⟷ T = [0, A, B]⇩∘"
proof(intro HOL.ext iffI)
interpret Par: semicategory α ‹smc_Par α› by (rule semicategory_smc_Par)
fix T A B assume "T : A ↦⇩0⇘smc_Par α⇙ B"
with smc_Par_is_arrD(1) obtain R S
where T_def: "T = R ∘⇩A⇘smc_Par α⇙ S"
and S: "S : A ↦⇘smc_Par α⇙ 0"
and R: "R : 0 ↦⇘smc_Par α⇙ B"
by (auto simp: arr_Par_def 𝒵.smc_Par_obj_initial obj_null_def)
interpret S: arr_Par α S
rewrites [simp]: "S⦇ArrDom⦈ = A" and [simp]: "S⦇ArrCod⦈ = 0"
using S smc_Par_is_arrD by auto
interpret R: arr_Par α R
rewrites [simp]: "R⦇ArrDom⦈ = 0" and [simp]: "R⦇ArrCod⦈ = B"
using R smc_Par_is_arrD by auto
have S_def: "S = [0, A, 0]⇩∘"
by
(
rule arr_Rel_eqI[of α],
unfold arr_Rel_components,
insert S.arr_Rel_ArrVal_vrange S.ArrVal.vbrelation_vintersection_vrange
)
(
auto simp:
S.arr_Rel_axioms
S.arr_Rel_ArrDom_in_Vset
arr_Rel_vfsequenceI vbrelationI
)
show "T = [0, A, B]⇩∘"
unfolding T_def smc_Par_Comp_app[OF R S]
by (rule arr_Rel_eqI[of α], unfold comp_Rel_components)
(
auto simp:
𝒵_axioms
S_def
R.arr_Rel_axioms
S.arr_Rel_axioms
arr_Rel_comp_Rel
arr_Rel_components
R.arr_Rel_ArrCod_in_Vset
S.arr_Rel_ArrDom_in_Vset
𝒵.arr_Rel_vfsequenceI
vbrelation_vempty
)
next
fix T assume prems: "T = [0, A, B]⇩∘"
let ?S = ‹[0, A, 0]⇩∘› and ?R = ‹[0, 0, B]⇩∘›
have S: "arr_Par α ?S" and R: "arr_Par α ?R"
by (all‹intro arr_Par_vfsequenceI›) (simp_all add: assms)
have SA0: "?S : A ↦⇘smc_Par α⇙ 0"
by (intro smc_Par_is_arrI) (simp_all add: S arr_Rel_components)
moreover have R0B: "?R : 0 ↦⇘smc_Par α⇙ B"
by (intro smc_Par_is_arrI) (simp_all add: R arr_Rel_components)
moreover have "T = ?R ∘⇩A⇘smc_Par α⇙ ?S"
unfolding smc_Par_Comp_app[OF R0B SA0]
proof
(
rule arr_Par_eqI[of α],
unfold comp_Rel_components arr_Rel_components prems
)
show "arr_Par α [0, A, B]⇩∘"
unfolding prems by (intro arr_Par_vfsequenceI) (auto simp: assms)
qed (use R S in ‹auto simp: smc_Par_cs_intros›)
ultimately show "T : A ↦⇩0⇘smc_Par α⇙ B"
by (simp add: is_zero_arrI smc_Par_obj_null)
qed
text‹\newpage›
end
Theory CZH_SMC_Set
section‹‹Set› as a semicategory›
theory CZH_SMC_Set
imports
CZH_DG_Set
CZH_SMC_Par
CZH_SMC_Subsemicategory
begin
subsection‹Background›
text‹
The methodology chosen for the exposition
of ‹Set› as a semicategory is analogous to the
one used in the previous chapter for the exposition of ‹Set› as a digraph.
›
named_theorems smc_Set_cs_simps
named_theorems smc_Set_cs_intros
lemmas (in arr_Set) [smc_Set_cs_simps] =
dg_Rel_shared_cs_simps
lemmas [smc_Set_cs_simps] =
dg_Rel_shared_cs_simps
arr_Set.arr_Set_ArrVal_vdomain
arr_Set_comp_Set_id_Set_left
arr_Set_comp_Set_id_Set_right
lemmas [smc_Set_cs_intros] =
dg_Rel_shared_cs_intros
arr_Set_comp_Set
subsection‹‹Set› as a semicategory›
subsubsection‹Definition and elementary properties›
definition smc_Set :: "V ⇒ V"
where "smc_Set α =
[
Vset α,
set {T. arr_Set α T},
(λT∈⇩∘set {T. arr_Set α T}. T⦇ArrDom⦈),
(λT∈⇩∘set {T. arr_Set α T}. T⦇ArrCod⦈),
(λST∈⇩∘composable_arrs (dg_Set α). ST⦇0⦈ ∘⇩R⇩e⇩l ST⦇1⇩ℕ⦈)
]⇩∘"
text‹Components.›
lemma smc_Set_components:
shows "smc_Set α⦇Obj⦈ = Vset α"
and "smc_Set α⦇Arr⦈ = set {T. arr_Set α T}"
and "smc_Set α⦇Dom⦈ = (λT∈⇩∘set {T. arr_Set α T}. T⦇ArrDom⦈)"
and "smc_Set α⦇Cod⦈ = (λT∈⇩∘set {T. arr_Set α T}. T⦇ArrCod⦈)"
and "smc_Set α⦇Comp⦈ = (λST∈⇩∘composable_arrs (dg_Set α). ST⦇0⦈ ∘⇩R⇩e⇩l ST⦇1⇩ℕ⦈)"
unfolding smc_Set_def dg_field_simps by (simp_all add: nat_omega_simps)
text‹Slicing.›
lemma smc_dg_smc_Set: "smc_dg (smc_Set α) = dg_Set α"
proof(rule vsv_eqI)
have dom_lhs: "𝒟⇩∘ (smc_dg (smc_Set α)) = 4⇩ℕ"
unfolding smc_dg_def by (simp add: nat_omega_simps)
have dom_rhs: "𝒟⇩∘ (dg_Set α) = 4⇩ℕ"
unfolding dg_Set_def by (simp add: nat_omega_simps)
show "𝒟⇩∘ (smc_dg (smc_Set α)) = 𝒟⇩∘ (dg_Set α)"
unfolding dom_lhs dom_rhs by simp
show "a ∈⇩∘ 𝒟⇩∘ (smc_dg (smc_Set α)) ⟹ smc_dg (smc_Set α)⦇a⦈ = dg_Set α⦇a⦈"
for a
by
(
unfold dom_lhs,
elim_in_numeral,
unfold smc_dg_def dg_field_simps smc_Set_def dg_Set_def
)
(auto simp: nat_omega_simps)
qed (auto simp: smc_dg_def dg_Set_def)
lemmas_with [folded smc_dg_smc_Set, unfolded slicing_simps]:
smc_Set_Obj_iff = dg_Set_Obj_iff
and smc_Set_Arr_iff[smc_Set_cs_simps] = dg_Set_Arr_iff
and smc_Set_Dom_vsv[smc_Set_cs_intros] = dg_Set_Dom_vsv
and smc_Set_Dom_vdomain[smc_Set_cs_simps] = dg_Set_Dom_vdomain
and smc_Set_Dom_vrange = dg_Set_Dom_vrange
and smc_Set_Dom_app[smc_Set_cs_simps] = dg_Set_Dom_app
and smc_Set_Cod_vsv[smc_Set_cs_intros] = dg_Set_Cod_vsv
and smc_Set_Cod_vdomain[smc_Set_cs_simps] = dg_Set_Cod_vdomain
and smc_Set_Cod_vrange = dg_Set_Cod_vrange
and smc_Set_Cod_app[smc_Set_cs_simps] = dg_Set_Cod_app
and smc_Set_is_arrI = dg_Set_is_arrI
and smc_Set_is_arrD = dg_Set_is_arrD
and smc_Set_is_arrE = dg_Set_is_arrE
and smc_Set_ArrVal_vdomain[smc_Set_cs_simps] = dg_Set_ArrVal_vdomain
and smc_Set_ArrVal_app_vrange[smc_Set_cs_intros] = dg_Set_ArrVal_app_vrange
lemmas [smc_cs_simps] = smc_Set_is_arrD(2,3)
lemmas_with (in 𝒵) [folded smc_dg_smc_Set, unfolded slicing_simps]:
smc_Set_Hom_vifunion_in_Vset = dg_Set_Hom_vifunion_in_Vset
and smc_Set_incl_Set_is_arr = dg_Set_incl_Set_is_arr
and smc_Set_incl_Set_is_arr'[smc_Set_cs_intros] = dg_Set_incl_Set_is_arr'
lemmas [smc_Set_cs_intros] =
smc_Set_is_arrI
𝒵.smc_Set_incl_Set_is_arr'
subsubsection‹Composable arrows›
lemma smc_Set_composable_arrs_dg_Set:
"composable_arrs (dg_Set α) = composable_arrs (smc_Set α)"
unfolding composable_arrs_def smc_dg_smc_Set[symmetric] slicing_simps by simp
lemma smc_Set_Comp:
"smc_Set α⦇Comp⦈ =
VLambda (composable_arrs (smc_Set α)) (λST. ST⦇0⦈ ∘⇩R⇩e⇩l ST⦇1⇩ℕ⦈)"
unfolding smc_Set_components smc_Set_composable_arrs_dg_Set ..
subsubsection‹Composition›
lemma smc_Set_Comp_app[smc_Set_cs_simps]:
assumes "S : b ↦⇘smc_Set α⇙ c" and "T : a ↦⇘smc_Set α⇙ b"
shows "S ∘⇩A⇘smc_Set α⇙ T = S ∘⇩R⇩e⇩l T"
proof-
from assms have "[S, T]⇩∘ ∈⇩∘ composable_arrs (smc_Set α)"
by (auto simp: smc_cs_intros)
then show "S ∘⇩A⇘smc_Set α⇙ T = S ∘⇩R⇩e⇩l T"
unfolding smc_Set_Comp by (simp add: nat_omega_simps)
qed
lemma smc_Set_Comp_vdomain: "𝒟⇩∘ (smc_Set α⦇Comp⦈) = composable_arrs (smc_Set α)"
unfolding smc_Set_Comp by simp
lemma (in 𝒵) smc_Set_Comp_vrange:
"ℛ⇩∘ (smc_Set α⦇Comp⦈) ⊆⇩∘ set {T. arr_Set α T}"
proof(rule vsubsetI)
interpret digraph α ‹smc_dg (smc_Set α)›
unfolding smc_dg_smc_Set by (simp add: digraph_dg_Set)
fix R assume "R ∈⇩∘ ℛ⇩∘ (smc_Set α⦇Comp⦈)"
then obtain ST
where R_def: "R = smc_Set α⦇Comp⦈⦇ST⦈"
and "ST ∈⇩∘ 𝒟⇩∘ (smc_Set α⦇Comp⦈)"
unfolding smc_Set_components by (blast dest: rel_VLambda.vrange_atD)
then obtain S T a b c
where "ST = [S, T]⇩∘"
and S: "S : b ↦⇘smc_Set α⇙ c"
and T: "T : a ↦⇘smc_Set α⇙ b"
by (auto simp: smc_Set_Comp_vdomain)
with R_def have R_def': "R = S ∘⇩A⇘smc_Set α⇙ T" by simp
interpret S: arr_Set α S + T: arr_Set α T
rewrites [simp]: "S⦇ArrDom⦈ = b"
and [simp]: "S⦇ArrCod⦈ = c"
and [simp]: "T⦇ArrDom⦈ = a"
and [simp]: "T⦇ArrCod⦈ = b"
using S T by (auto elim!: smc_Set_is_arrD)
have "ℛ⇩∘ (T⦇ArrVal⦈) ⊆⇩∘ 𝒟⇩∘ (S⦇ArrVal⦈)"
proof(intro vsubsetI)
fix y assume prems: "y ∈⇩∘ ℛ⇩∘ (T⦇ArrVal⦈)"
with T.ArrVal.vrange_atD obtain x
where y_def: "y = T⦇ArrVal⦈⦇x⦈" and x: "x ∈⇩∘ 𝒟⇩∘ (T⦇ArrVal⦈)"
by metis
from prems x T.arr_Set_ArrVal_vrange show "y ∈⇩∘ 𝒟⇩∘ (S⦇ArrVal⦈)"
unfolding y_def by (auto simp: smc_Set_cs_simps)
qed
with S.arr_Set_axioms T.arr_Set_axioms have "arr_Set α (S ∘⇩R⇩e⇩l T)"
by (simp add: arr_Set_comp_Set)
from this show "R ∈⇩∘ set {T. arr_Set α T}"
unfolding R_def' smc_Set_Comp_app[OF S T] by simp
qed
lemma smc_Set_composable_vrange_vdomain[smc_Set_cs_intros]:
assumes "g : b ↦⇘smc_Set α⇙ c" and "f : a ↦⇘smc_Set α⇙ b"
shows "ℛ⇩∘ (f⦇ArrVal⦈) ⊆⇩∘ 𝒟⇩∘ (g⦇ArrVal⦈)"
proof(intro vsubsetI)
from assms have g: "arr_Set α g" and f: "arr_Set α f"
by (auto simp: smc_Set_is_arrD)
fix y assume "y ∈⇩∘ ℛ⇩∘ (f⦇ArrVal⦈)"
with assms f have "y ∈⇩∘ b" by (force simp: smc_Set_is_arrD(3))
with assms g show "y ∈⇩∘ 𝒟⇩∘ (g⦇ArrVal⦈)"
by (simp add: smc_Set_is_arrD(2) arr_SetD(5))
qed
lemma smc_Set_Comp_ArrVal[smc_cs_simps]:
assumes "S : y ↦⇘smc_Set α⇙ z" and "T : x ↦⇘smc_Set α⇙ y" and "a ∈⇩∘ x"
shows "(S ∘⇩A⇘smc_Set α⇙ T)⦇ArrVal⦈⦇a⦈ = S⦇ArrVal⦈⦇T⦇ArrVal⦈⦇a⦈⦈"
proof-
interpret S: arr_Set α S + T: arr_Set α T
using assms by (auto simp: smc_Set_is_arrD)
have Ta: "T⦇ArrVal⦈⦇a⦈ ∈⇩∘ y"
proof-
from assms have "a ∈⇩∘ T⦇ArrDom⦈" by (auto simp: smc_Set_is_arrD)
with assms T.arr_Set_ArrVal_vrange show ?thesis
by
(
simp add:
T.ArrVal.vsv_vimageI2 vsubset_iff smc_Set_is_arrD smc_Set_cs_simps
)
qed
from Ta assms S.arr_Set_axioms T.arr_Set_axioms show ?thesis
by ((cs_concl_step smc_Set_cs_simps)+, intro arr_Set_comp_Set_ArrVal[of α])
(simp_all add: smc_Set_is_arrD smc_Set_cs_simps)
qed
subsubsection‹‹Set› is a semicategory›
lemma (in 𝒵) semicategory_smc_Set: "semicategory α (smc_Set α)"
proof(rule semicategoryI, unfold smc_dg_smc_Set)
interpret wide_subdigraph α ‹dg_Set α› ‹dg_Par α›
by (rule wide_subdigraph_dg_Set_dg_Par)
interpret smc_Par: semicategory α ‹smc_Par α› by (rule semicategory_smc_Par)
show "vfsequence (smc_Set α)" unfolding smc_Set_def by simp
show "vcard (smc_Set α) = 5⇩ℕ"
unfolding smc_Set_def by (simp add: nat_omega_simps)
show "(gf ∈⇩∘ 𝒟⇩∘ (smc_Set α⦇Comp⦈)) ⟷
(∃g f b c a. gf = [g, f]⇩∘ ∧ g : b ↦⇘smc_Set α⇙ c ∧ f : a ↦⇘smc_Set α⇙ b)"
for gf
unfolding smc_Set_Comp_vdomain by (auto intro: composable_arrsI)
show [intro]: "g ∘⇩A⇘smc_Set α⇙ f : a ↦⇘smc_Set α⇙ c"
if "g : b ↦⇘smc_Set α⇙ c" "f : a ↦⇘smc_Set α⇙ b" for g b c f a
proof-
from that have g: "arr_Set α g" and f: "arr_Set α f"
by (auto simp: smc_Set_is_arrD)
with that show ?thesis
by
(
cs_concl
cs_simp: smc_cs_simps smc_Set_cs_simps
cs_intro: smc_Set_cs_intros
)
qed
show "h ∘⇩A⇘smc_Set α⇙ g ∘⇩A⇘smc_Set α⇙ f = h ∘⇩A⇘smc_Set α⇙ (g ∘⇩A⇘smc_Set α⇙ f)"
if "h : c ↦⇘smc_Set α⇙ d"
and "g : b ↦⇘smc_Set α⇙ c"
and "f : a ↦⇘smc_Set α⇙ b"
for h c d g b f a
proof-
from that have "arr_Set α h" "arr_Set α g" "arr_Set α f"
by (auto simp: smc_Set_is_arrD)
with that show ?thesis
by
(
cs_concl
cs_simp: smc_cs_simps smc_Set_cs_simps
cs_intro: smc_Set_cs_intros
)
qed
qed (auto simp: digraph_dg_Set smc_Set_components)
subsubsection‹‹Set› is a wide subsemicategory of ‹Par››
lemma (in 𝒵) wide_subsemicategory_smc_Set_smc_Par:
"smc_Set α ⊆⇩S⇩M⇩C⇩.⇩w⇩i⇩d⇩e⇘α⇙ smc_Par α"
proof-
interpret Par: semicategory α ‹smc_Par α› by (rule semicategory_smc_Par)
interpret Set: semicategory α ‹smc_Set α› by (rule semicategory_smc_Set)
show ?thesis
proof
(
intro wide_subsemicategoryI subsemicategoryI,
unfold smc_dg_smc_Par smc_dg_smc_Set
)
from wide_subdigraph_dg_Set_dg_Par show wsd:
"dg_Set α ⊆⇩D⇩G⇘α⇙ dg_Par α"
"dg_Set α ⊆⇩D⇩G⇩.⇩w⇩i⇩d⇩e⇘α⇙ dg_Par α"
by auto
interpret wide_subdigraph α ‹dg_Set α› ‹dg_Par α› by (rule wsd(2))
show "g ∘⇩A⇘smc_Set α⇙ f = g ∘⇩A⇘smc_Par α⇙ f"
if "g : b ↦⇘smc_Set α⇙ c" and "f : a ↦⇘smc_Set α⇙ b" for g b c f a
proof-
from that have "g : b ↦⇘dg_Set α⇙ c" and "f : a ↦⇘dg_Set α⇙ b"
by (cs_concl cs_simp: smc_dg_smc_Set[symmetric] cs_intro: slicing_intros)+
then have "g : b ↦⇘dg_Par α⇙ c" and "f : a ↦⇘dg_Par α⇙ b"
by (cs_concl cs_intro: dg_sub_fw_cs_intros)+
then have "g : b ↦⇘smc_Par α⇙ c" and "f : a ↦⇘smc_Par α⇙ b"
unfolding smc_dg_smc_Par[symmetric] slicing_simps by simp_all
from that this show "g ∘⇩A⇘smc_Set α⇙ f = g ∘⇩A⇘smc_Par α⇙ f"
by (cs_concl cs_simp: smc_Set_cs_simps smc_Par_cs_simps)
qed
qed (auto simp: smc_cs_intros)
qed
subsection‹Monic arrow and epic arrow›
lemma (in 𝒵) smc_Set_is_monic_arrI:
assumes "T : A ↦⇘smc_Set α⇙ B" and "v11 (T⦇ArrVal⦈)" and "𝒟⇩∘ (T⦇ArrVal⦈) = A"
shows "T : A ↦⇩m⇩o⇩n⇘smc_Set α⇙ B"
proof(rule is_monic_arrI)
interpret wide_subsemicategory α ‹smc_Set α› ‹smc_Par α›
by (rule wide_subsemicategory_smc_Set_smc_Par)
interpret v11 ‹T⦇ArrVal⦈› by (rule assms(2))
show T: "T : A ↦⇘smc_Set α⇙ B" by (rule assms(1))
fix S R A'
assume S: "S : A' ↦⇘smc_Set α⇙ A"
and R: "R : A' ↦⇘smc_Set α⇙ A"
and TS_TR: "T ∘⇩A⇘smc_Set α⇙ S = T ∘⇩A⇘smc_Set α⇙ R"
from assms(3) T have "T : A ↦⇩m⇩o⇩n⇘smc_Par α⇙ B"
by (intro smc_Par_is_monic_arrI)
(auto simp: v11_axioms dest: subsmc_is_arrD)
moreover from S subsemicategory_axioms have "S : A' ↦⇘smc_Par α⇙ A"
by (cs_concl cs_intro: smc_sub_fw_cs_intros)
moreover from R subsemicategory_axioms have "R : A' ↦⇘smc_Par α⇙ A"
by (cs_concl cs_intro: smc_sub_fw_cs_intros)
moreover from T S R TS_TR subsemicategory_axioms have
"T ∘⇩A⇘smc_Par α⇙ S = T ∘⇩A⇘smc_Par α⇙ R"
by (auto simp: smc_sub_bw_cs_simps)
ultimately show "S = R" by (rule is_monic_arrD(2))
qed
lemma (in 𝒵) smc_Set_is_monic_arrD:
assumes "T : A ↦⇩m⇩o⇩n⇘smc_Set α⇙ B"
shows "T : A ↦⇘smc_Set α⇙ B" and "v11 (T⦇ArrVal⦈)" and "𝒟⇩∘ (T⦇ArrVal⦈) = A"
proof-
interpret wide_subdigraph α ‹dg_Set α› ‹dg_Par α›
by (rule wide_subdigraph_dg_Set_dg_Par)
interpret Par: semicategory α ‹smc_Par α› by (rule semicategory_smc_Par)
from assms show T: "T : A ↦⇘smc_Set α⇙ B" by auto
interpret T: arr_Set α T
rewrites [simp]: "T⦇ArrDom⦈ = A" and [simp]: "T⦇ArrCod⦈ = B"
using T by (auto elim!: smc_Set_is_arrE)
show "v11 (T⦇ArrVal⦈)"
proof(rule v11I)
show "vsv ((T⦇ArrVal⦈)¯⇩∘)"
proof(rule vsvI)
fix a b c assume "⟨a, b⟩ ∈⇩∘ (T⦇ArrVal⦈)¯⇩∘" and "⟨a, c⟩ ∈⇩∘ (T⦇ArrVal⦈)¯⇩∘"
then have bar: "⟨b, a⟩ ∈⇩∘ T⦇ArrVal⦈" and car: "⟨c, a⟩ ∈⇩∘ T⦇ArrVal⦈"
by auto
with T.arr_Set_ArrVal_vdomain have [intro]: "b ∈⇩∘ A" "c ∈⇩∘ A" by blast+
define R where "R = [set {⟨0, b⟩}, set {0}, A]⇩∘"
define S where "S = [set {⟨0, c⟩}, set {0}, A]⇩∘"
have R: "R : set {0} ↦⇘smc_Set α⇙ A"
proof(rule smc_Set_is_arrI)
show "arr_Set α R"
unfolding R_def
by (rule arr_Set_vfsequenceI) (auto simp: T.arr_Rel_ArrDom_in_Vset)
qed (simp_all add: R_def arr_Rel_components)
interpret R: arr_Set α R
rewrites [simp]: "R⦇ArrDom⦈ = set {0}" and [simp]: "R⦇ArrCod⦈ = A"
using R by (auto elim!: smc_Set_is_arrE)
have S: "S : set {0} ↦⇘smc_Set α⇙ A"
proof(rule smc_Set_is_arrI)
show "arr_Set α S"
unfolding S_def
by (rule arr_Set_vfsequenceI) (auto simp: T.arr_Rel_ArrDom_in_Vset)
qed (simp_all add: S_def arr_Rel_components)
interpret S: arr_Set α S
rewrites [simp]: "S⦇ArrDom⦈ = set {0}" and [simp]: "S⦇ArrCod⦈ = A"
using S by (auto elim!: smc_Set_is_arrE)
have "T ∘⇩A⇘smc_Set α⇙ R = [set {⟨0, a⟩}, set {0}, B]⇩∘"
unfolding smc_Set_Comp_app[OF T R]
proof
(
rule arr_Set_eqI[of α],
unfold comp_Rel_components arr_Rel_components
)
from R T show "arr_Set α (T ∘⇩R⇩e⇩l R)"
by (intro arr_Set_comp_Set)
(auto elim!: smc_Set_is_arrE simp: smc_Set_cs_simps)
show "arr_Set α [set {⟨0, a⟩}, set {0}, B]⇩∘"
proof(rule arr_Set_vfsequenceI)
from T.arr_Rel_ArrVal_vrange bar show "ℛ⇩∘ (set {⟨0, a⟩}) ⊆⇩∘ B" by auto
qed (auto simp: T.arr_Rel_ArrCod_in_Vset Axiom_of_Powers)
show "T⦇ArrVal⦈ ∘⇩∘ R⦇ArrVal⦈ = set {⟨0, a⟩}"
unfolding R_def arr_Rel_components
proof(rule vsv_eqI, unfold vdomain_vsingleton)
from bar show "𝒟⇩∘ (T⦇ArrVal⦈ ∘⇩∘ set {⟨0, b⟩}) = set {0}" by auto
with bar show "a' ∈⇩∘ 𝒟⇩∘ (T⦇ArrVal⦈ ∘⇩∘ set {⟨0, b⟩}) ⟹
(T⦇ArrVal⦈ ∘⇩∘ set {⟨0, b⟩})⦇a'⦈ = set {⟨0, a⟩}⦇a'⦈"
for a'
by auto
qed (auto intro: vsv_vcomp)
qed (simp_all add: R_def arr_Rel_components)
moreover have "T ∘⇩A⇘smc_Set α⇙ S = [set {⟨0, a⟩}, set {0}, B]⇩∘"
unfolding smc_Set_Comp_app[OF T S]
proof
(
rule arr_Set_eqI[of α],
unfold comp_Rel_components arr_Rel_components
)
from T S show "arr_Set α (T ∘⇩R⇩e⇩l S)"
by (intro arr_Set_comp_Set)
(
auto simp:
T.arr_Set_axioms
smc_Set_is_arrD
S.arr_Set_ArrVal_vrange
smc_Set_cs_simps
)
show "arr_Set α [set {⟨0, a⟩}, set {0}, B]⇩∘"
proof(rule arr_Set_vfsequenceI)
from T.arr_Rel_ArrVal_vrange bar show "ℛ⇩∘ (set {⟨0, a⟩}) ⊆⇩∘ B" by auto
qed (auto simp: T.arr_Rel_ArrCod_in_Vset Axiom_of_Powers)
show "T⦇ArrVal⦈ ∘⇩∘ S⦇ArrVal⦈ = set {⟨0, a⟩}"
unfolding S_def arr_Rel_components
proof(rule vsv_eqI, unfold vdomain_vsingleton)
from car show "𝒟⇩∘ (T⦇ArrVal⦈ ∘⇩∘ set {⟨0, c⟩}) = set {0}" by auto
with car show "a' ∈⇩∘ 𝒟⇩∘ (T⦇ArrVal⦈ ∘⇩∘ set {⟨0, c⟩}) ⟹
(T⦇ArrVal⦈ ∘⇩∘ set {⟨0, c⟩})⦇a'⦈ = set {⟨0, a⟩}⦇a'⦈"
for a'
by auto
qed (auto intro: vsv_vcomp)
qed (simp_all add: S_def arr_Rel_components)
ultimately have "T ∘⇩A⇘smc_Set α⇙ R = T ∘⇩A⇘smc_Set α⇙ S" by simp
from R S assms this have "R = S" by clarsimp
then have "R⦇ArrVal⦈ = S⦇ArrVal⦈" by simp
then show "b = c" unfolding R_def S_def arr_Rel_components by simp
qed clarsimp
qed auto
show "𝒟⇩∘ (T⦇ArrVal⦈) = A" by (simp add: smc_Set_cs_simps)
qed
lemma (in 𝒵) smc_Set_is_monic_arr:
"T : A ↦⇩m⇩o⇩n⇘smc_Set α⇙ B ⟷
T : A ↦⇘smc_Set α⇙ B ∧ v11 (T⦇ArrVal⦈) ∧ 𝒟⇩∘ (T⦇ArrVal⦈) = A"
by (rule iffI) (auto simp: smc_Set_is_monic_arrD smc_Set_is_monic_arrI)
text‹
An epic arrow in ‹Set› is a total surjective function (see Chapter I-5
in \cite{mac_lane_categories_2010}).
›
lemma (in 𝒵) smc_Set_is_epic_arrI:
assumes "T : A ↦⇘smc_Set α⇙ B" and "ℛ⇩∘ (T⦇ArrVal⦈) = B"
shows "T : A ↦⇩e⇩p⇩i⇘smc_Set α⇙ B"
proof-
interpret wide_subsemicategory α ‹smc_Set α› ‹smc_Par α›
by (rule wide_subsemicategory_smc_Set_smc_Par)
have epi_T: "T : A ↦⇩e⇩p⇩i⇘smc_Par α⇙ B"
using assms by (meson smc_Par_is_epic_arr subsmc_is_arrD)
show ?thesis
proof(rule sdg.is_epic_arrI)
show T: "T : A ↦⇘smc_Set α⇙ B" by (rule assms(1))
fix f g a
assume prems:
"f : B ↦⇘smc_Set α⇙ a"
"g : B ↦⇘smc_Set α⇙ a"
"f ∘⇩A⇘smc_Set α⇙ T = g ∘⇩A⇘smc_Set α⇙ T"
from prems(1) subsemicategory_axioms have "f : B ↦⇘smc_Par α⇙ a"
by (cs_concl cs_intro: smc_sub_fw_cs_intros)
moreover from prems(2) subsemicategory_axioms have "g : B ↦⇘smc_Par α⇙ a"
by (cs_concl cs_intro: smc_sub_fw_cs_intros)
moreover from prems T subsemicategory_axioms have
"f ∘⇩A⇘smc_Par α⇙ T = g ∘⇩A⇘smc_Par α⇙ T"
by (auto simp: smc_sub_bw_cs_simps)
ultimately show "f = g"
by (rule dg.is_epic_arrD(2)[OF epi_T])
qed
qed
lemma (in 𝒵) smc_Set_is_epic_arrD:
assumes "T : A ↦⇩e⇩p⇩i⇘smc_Set α⇙ B"
shows "T : A ↦⇘smc_Set α⇙ B" and "ℛ⇩∘ (T⦇ArrVal⦈) = B"
proof-
interpret semicategory α ‹smc_Set α› by (rule semicategory_smc_Set)
from assms show T: "T : A ↦⇘smc_Set α⇙ B" by auto
interpret T: arr_Set α T
rewrites "T⦇ArrDom⦈ = A" and "T⦇ArrCod⦈ = B"
using T by (auto elim!: smc_Set_is_arrE)
show "ℛ⇩∘ (T⦇ArrVal⦈) = B"
proof(intro vsubset_antisym vsubsetI)
fix b assume [intro]: "b ∈⇩∘ B"
show "b ∈⇩∘ ℛ⇩∘ (T⦇ArrVal⦈)"
proof(rule ccontr)
assume b: "b ∉⇩∘ ℛ⇩∘ (T⦇ArrVal⦈)"
define R
where "R = [vinsert ⟨b, 0⟩ ((B -⇩∘ set {b}) ×⇩∘ set {1}), B, set {0, 1}]⇩∘"
define S where "S = [B ×⇩∘ set {1}, B, set {0, 1}]⇩∘"
have R: "R : B ↦⇘smc_Set α⇙ set {0, 1}"
unfolding R_def
proof(intro smc_Set_is_arrI arr_Set_vfsequenceI, unfold arr_Rel_components)
from Axiom_of_Infinity vone_in_omega show "set {0, 1} ∈⇩∘ Vset α" by blast
qed (auto simp: T.arr_Rel_ArrCod_in_Vset)
have S: "S : B ↦⇘smc_Set α⇙ set {0, 1}"
unfolding S_def
proof(intro smc_Set_is_arrI arr_Set_vfsequenceI, unfold arr_Rel_components)
from Axiom_of_Infinity vone_in_omega show "set {0, 1} ∈⇩∘ Vset α" by blast
qed (auto simp: T.arr_Rel_ArrCod_in_Vset)
from b have "R⦇ArrVal⦈ ∘⇩∘ T⦇ArrVal⦈ = S⦇ArrVal⦈ ∘⇩∘ T⦇ArrVal⦈"
unfolding S_def R_def arr_Rel_components
by (auto intro!: vsubset_antisym vsubsetI)
then have "R ∘⇩A⇘smc_Set α⇙ T = S ∘⇩A⇘smc_Set α⇙ T"
unfolding smc_Set_Comp_app[OF R T] smc_Set_Comp_app[OF S T]
by (simp add: R_def S_def arr_Rel_components comp_Rel_def)
from R S this have "R = S" by (rule is_epic_arrD(2)[OF assms])
with zero_neq_one show False unfolding R_def S_def by blast
qed
qed (use T.arr_Set_ArrVal_vrange in auto)
qed
lemma (in 𝒵) smc_Set_is_epic_arr:
"T : A ↦⇩e⇩p⇩i⇘smc_Set α⇙ B ⟷ T : A ↦⇘smc_Set α⇙ B ∧ ℛ⇩∘ (T⦇ArrVal⦈) = B"
by (rule iffI) (simp_all add: smc_Set_is_epic_arrD smc_Set_is_epic_arrI)
subsection‹Terminal object, initial object and null object›
text‹An object in ‹Set› is terminal if and only if it is a singleton
set (see Chapter I-5 in \cite{mac_lane_categories_2010}).›
lemma (in 𝒵) smc_Set_obj_terminal:
"obj_terminal (smc_Set α) A ⟷ (∃B∈⇩∘Vset α. A = set {B})"
proof-
interpret semicategory α ‹smc_Set α› by (rule semicategory_smc_Set)
have "(∀A∈⇩∘Vset α. ∃!T. T : A ↦⇘smc_Set α⇙ B) ⟷ (∃C∈⇩∘Vset α. B = set {C})"
for B
proof(intro iffI ballI)
assume prems[rule_format]: "∀A∈⇩∘Vset α. ∃!T. T : A ↦⇘smc_Set α⇙ B"
then obtain T where T0B: "T : 0 ↦⇘smc_Set α⇙ B" by (meson vempty_is_zet)
then have B[simp]: "B ∈⇩∘ Vset α" by (fastforce simp: smc_Set_components(1))
show "∃C∈⇩∘Vset α. B = set {C}"
proof(rule ccontr, cases ‹B = 0›)
case True
from prems have "∃!T. T : A ↦⇘smc_Set α⇙ 0" if "A ∈⇩∘ Vset α" for A
using that unfolding True by simp
then obtain T where T: "T : set {0} ↦⇘smc_Set α⇙ 0"
by (metis Axiom_of_Pairing insert_absorb2 vempty_is_zet)
interpret T: arr_Set α T
rewrites "T⦇ArrDom⦈ = set {0}" and "T⦇ArrCod⦈ = 0"
using T by (auto elim!: smc_Set_is_arrE)
from
T.vdomain_vrange_is_vempty
T.ArrVal.vdomain_vrange_is_vempty
T.arr_Set_ArrVal_vrange
show False
by (auto simp: smc_Set_cs_simps)
next
case False
assume "¬(∃C∈⇩∘Vset α. B = set {C})"
with B have "∄C. B = set {C}" by blast
with False obtain a b where ab: "a ≠ b" "a ∈⇩∘ B" "b ∈⇩∘ B"
by (metis V_equalityI vemptyE vintersection_vsingleton vsingletonD)
have "[set {⟨0, a⟩}, set {0}, B]⇩∘ : set {0} ↦⇘smc_Set α⇙ B"
by (intro smc_Set_is_arrI arr_SetI, unfold arr_Rel_components)
(auto simp: ab(2) nat_omega_simps)
moreover from ab have
"[set {⟨0, b⟩}, set {0}, B]⇩∘ : set {0} ↦⇘smc_Set α⇙ B"
by (intro smc_Set_is_arrI arr_SetI, unfold arr_Rel_components)
(auto simp: ab(2) nat_omega_simps)
moreover with ab have
"[set {⟨0, a⟩}, set {0}, B]⇩∘ ≠ [set {⟨0, b⟩}, set {0}, B]⇩∘"
by simp
ultimately show False
by (metis prems smc_is_arrE smc_Set_components(1))
qed
next
fix A assume prems: "∃b∈⇩∘Vset α. B = set {b}" "A ∈⇩∘ Vset α"
then obtain b where B_def: "B = set {b}" and b: "b ∈⇩∘ Vset α" by blast
have "vconst_on A b = A ×⇩∘ set {b}" by (simp add: vconst_on_eq_vtimes)
show "∃!T. T : A ↦⇘smc_Set α⇙ B"
unfolding B_def
proof(rule ex1I[of _ ‹[A ×⇩∘ set {b}, A, set {b}]⇩∘›])
show "[A ×⇩∘ set {b}, A, set {b}]⇩∘ : A ↦⇘smc_Set α⇙ set {b}"
using b
by
(
intro smc_Set_is_arrI arr_Set_vfsequenceI,
unfold arr_Rel_components
)
(auto simp: prems(2) vconst_on_eq_vtimes[symmetric])
fix T assume prems: "T : A ↦⇘smc_Set α⇙ set {b}"
interpret T: arr_Set α T
rewrites [simp]: "T⦇ArrDom⦈ = A" and [simp]: "T⦇ArrCod⦈ = set {b}"
using prems by (auto elim!: smc_Set_is_arrE)
have [simp]: "T⦇ArrVal⦈ = A ×⇩∘ set {b}"
proof(intro vsubset_antisym vsubsetI)
fix x assume prems: "x ∈⇩∘ T⦇ArrVal⦈"
with T.vbrelation_axioms app_vdomainI obtain a b'
where "x = ⟨a, b'⟩" and "a ∈⇩∘ A"
by (metis T.ArrVal.vbrelation_vinE T.arr_Set_ArrVal_vdomain)
with prems T.arr_Set_ArrVal_vrange show "x ∈⇩∘ A ×⇩∘ set {b}" by auto
next
fix x assume "x ∈⇩∘ A ×⇩∘ set {b}"
then obtain a where x_def: "x = ⟨a, b⟩" and "a ∈⇩∘ A" by clarsimp
have "𝒟⇩∘ (T⦇ArrVal⦈) = A" by (simp add: smc_Set_cs_simps)
moreover with
T.arr_Set_ArrVal_vrange T.ArrVal.vdomain_vrange_is_vempty ‹a ∈⇩∘ A›
have "ℛ⇩∘ (T⦇ArrVal⦈) = set {b}"
by auto
ultimately show "x ∈⇩∘ T⦇ArrVal⦈"
using ‹a ∈⇩∘ A›
unfolding x_def
by
(
metis
T.ArrVal.vsv_ex1_app1
T.ArrVal.vsv_vimageI1
vimage_vdomain
vsingletonD
)
qed
show "T = [A ×⇩∘ set {b}, A, set {b}]⇩∘"
proof(rule arr_Set_eqI[of α], unfold arr_Rel_components)
show "arr_Set α [A ×⇩∘ set {b}, A, set {b}]⇩∘"
using T.arr_Rel_def T.arr_Set_axioms by auto
qed (auto simp: T.arr_Set_axioms)
qed
qed
then show ?thesis
apply(intro iffI obj_terminalI)
subgoal by (metis smc_is_arrD(2) obj_terminalE)
subgoal by blast
subgoal by (metis smc_Set_components(1))
done
qed
text‹An object in ‹Set› is initial if and only if it is the empty
set (see Chapter I-5 in \cite{mac_lane_categories_2010}).›
lemma (in 𝒵) smc_Set_obj_initial: "obj_initial (smc_Set α) A ⟷ A = 0"
proof-
interpret semicategory α ‹smc_Set α› by (rule semicategory_smc_Set)
have "(∀B∈⇩∘Vset α. ∃!T. T : A ↦⇘smc_Set α⇙ B) ⟷ A = 0" for A
proof(intro iffI ballI)
assume prems[rule_format]: "∀B∈⇩∘Vset α. ∃!T. T : A ↦⇘smc_Set α⇙ B"
then obtain T where T0B: "T : A ↦⇘smc_Set α⇙ 0" by (meson vempty_is_zet)
then have A[simp]: "A ∈⇩∘ Vset α" by (fastforce simp: smc_Set_components(1))
show "A = 0"
proof(rule ccontr)
assume "A ≠ 0"
then obtain a where a: "a ∈⇩∘ A" by (auto dest: trad_foundation)
from Axiom_of_Powers a have A0:
"[A ×⇩∘ set {0}, A, set {0}]⇩∘ : A ↦⇘smc_Set α⇙ set {0}"
by
(
intro smc_Set_is_arrI arr_Set_vfsequenceI,
unfold arr_Rel_components
)
auto
have A1: "[A ×⇩∘ set {1}, A, set {1}]⇩∘ : A ↦⇘smc_Set α⇙ set {1}"
proof
(
intro smc_Set_is_arrI arr_Set_vfsequenceI,
unfold arr_Rel_components
)
show "set {1} ∈⇩∘ Vset α" by (blast intro: vone_in_omega Axiom_of_Infinity)
qed auto
have "[A ×⇩∘ set {0}, A, set {0, 1}]⇩∘ : A ↦⇘smc_Set α⇙ set {0, 1}"
proof
(
intro smc_Set_is_arrI arr_Set_vfsequenceI,
unfold arr_Rel_components
)
show "set {[]⇩∘, 1} ∈⇩∘ Vset α"
by (intro Limit_vdoubleton_in_VsetI) (force simp: nat_omega_simps)+
qed auto
moreover have
"[A ×⇩∘ set {1}, A, set {0, 1}]⇩∘ : A ↦⇘smc_Set α⇙ set {0, 1}"
proof
(
intro smc_Set_is_arrI arr_Set_vfsequenceI,
unfold arr_Rel_components
)
show "set {[]⇩∘, 1} ∈⇩∘ Vset α"
by (intro Limit_vdoubleton_in_VsetI) (force simp: nat_omega_simps)+
qed auto
moreover from ‹A ≠ 0› one_neq_zero have
"[A ×⇩∘ set {0}, A, set {0, 1}]⇩∘ ≠ [A ×⇩∘ set {1}, A, set {0, 1}]⇩∘"
by (blast intro!: vsubset_antisym)
ultimately show False
by (metis prems smc_is_arrE smc_Set_components(1))
qed
next
fix B assume prems: "A = 0" "B ∈⇩∘ Vset α"
show "∃!T. T : A ↦⇘smc_Set α⇙ B"
proof(rule ex1I[of _ ‹[0, 0, B]⇩∘›], unfold prems(1))
show zzB: "[0, 0, B]⇩∘ : 0 ↦⇘smc_Set α⇙ B"
by
(
intro smc_Set_is_arrI arr_Set_vfsequenceI,
unfold arr_Rel_components
)
(simp_all add: prems)
fix T assume prems: "T : 0 ↦⇘smc_Set α⇙ B"
interpret T: arr_Set α T
rewrites [simp]: "T⦇ArrDom⦈ = 0" and [simp]: "T⦇ArrCod⦈ = B"
using prems by (auto simp: smc_Set_is_arrD)
show "T = [0, 0, B]⇩∘"
proof(rule arr_Set_eqI[of α], unfold arr_Rel_components)
show "arr_Set α T" by (rule T.arr_Set_axioms)
from zzB show "arr_Set α [[]⇩∘, []⇩∘, B]⇩∘" by (meson smc_Set_is_arrE)
from T.ArrVal.vdomain_vrange_is_vempty show "T⦇ArrVal⦈ = []⇩∘"
by (auto intro: T.ArrVal.vsv_vrange_vempty simp: smc_Set_cs_simps)
qed simp_all
qed
qed
then show ?thesis
apply(intro iffI obj_initialI, elim obj_initialE)
subgoal by (metis smc_Set_components(1))
subgoal by (simp add: smc_Set_components(1))
subgoal by (metis smc_Set_components(1))
done
qed
text‹
There are no null objects in ‹Set› (this is a trivial corollary of the
above).
›
lemma (in 𝒵) smc_Set_obj_null: "obj_null (smc_Set α) A ⟷ False"
unfolding obj_null_def smc_Set_obj_terminal smc_Set_obj_initial by simp
subsection‹Zero arrow›
text‹
There are no zero arrows in ‹Set› (this result is a trivial
corollary of the absence of null objects).
›
lemma (in 𝒵) smc_Set_is_zero_arr: "T : A ↦⇩0⇘smc_Set α⇙ B ⟷ False"
using smc_Set_obj_null unfolding is_zero_arr_def by auto
text‹\newpage›
end